- Aug 14, 2018
- Office Version
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
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.
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