dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,352
- Office Version
- 365
- 2016
- Platform
- Windows
I have a sub that cycles through the correct, filtered entries, asking if they are the correct entry. I have two entries that are filtered and am asked the question twice.
At the moment
What I need
Thanks
At the moment
- if I have 2 filtered rows, it doesn't matter what row I press Yes for, they both will be moved to the cancellations sheet.
What I need
- If I press Yes when a certain row is highlighted, that row is moved to the cancellations sheet as per the code below.
VBA Code:
Sub Transfer()
Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, AutoFilterCounter As Long
Set sh = Sheets("Totals")
Set sht = Sheets("Cancellations")
Dim Req As String: Req = sh.[B25].Value
Dim Dt As String: Dt = sh.[B27].Value
Dim SheetCounter As Integer: SheetCounter = 0
'Call TurnOffFunctionality
For Each ws In Worksheets
If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
With ws.[A3].CurrentRegion
.AutoFilter 1, Dt ' autofilter for the value in cell [B27]
.AutoFilter 3, Req ' autofilter for the value in cell [B25]
'Check to see if the date cell, column A, for a job has anything in it. If it doesn't, turn the autofilter off and skip to the next sheet.
If ws.[A3].Cells.Offset(1, 0) = "" Then
.AutoFilter
SheetCounter = SheetCounter + 1
'If SheetCounter = 12, none of the 12 monthly sheets have the entered date and request number so let the user know
If SheetCounter = 12 Then
MsgBox "A job with the date and request number entered does not exist"
End If
GoTo SkipSheet
End If
'Check the count Autofilter
AutoFilterCounter = .Columns(1).SpecialCells(xlCellTypeVisible).Count
'If value less than 2, only the heading is visible so skip to the next sheet.
If AutoFilterCounter < 2 Then
.AutoFilter
'Add 1 to a sheet counter
SheetCounter = SheetCounter + 1
'If SheetCounter = 12, none of the 12 monthly sheets have the entered date and request number so let the user know
If SheetCounter = 12 Then
MsgBox "A job with the date and request number entered does not exist"
End If
GoTo SkipSheet
End If
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim rng As Range: Set rng = ws.Range("A4:A" & LastRow)
Dim rws&: rws = Range("A4:A" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Count
'if this range is greater than 1, ask the below question, else continue
If rws > 1 Then
'If ws.Range("A4", ws.Range("A4").End(xlDown)) > 1 Then
Dim answer As Integer
Dim RowNumber As Long
Dim RowLine As Range
Application.ScreenUpdating = True
For Each RowLine In rng.SpecialCells(xlCellTypeVisible)
ws.Activate
RowLine.EntireRow.Interior.ColorIndex = 6
answer = MsgBox("Is this the job you want to apply the late cancel price too?", vbQuestion + vbYesNo + vbDefaultButton2, "Late Cancel Price")
RowLine.EntireRow.Interior.ColorIndex = 0
If answer = vbYes Then
'I had to include a -3 in here to account for the 3 rows above the data that don't have data in them
RowNumber = RowLine.Row - 3
GoTo FoundRightJob
End If
'If answer = vbNo
Next RowLine
End If
FoundRightJob:
.Offset(1).EntireRow.Copy sht.Range("A" & Rows.Count).End(xlUp).Offset(1)
.Offset(1).EntireRow.Delete
.AutoFilter ' turn off the autofilter
End With
End If
SkipSheet:
Next ws
'sh.Range("B25,B27").ClearContents
'Call TurnOnFunctionality
End Sub
Thanks