Need specific row to be moved

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,147
Office Version
  1. 365
  2. 2016
Platform
  1. 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
  • 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
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
You're welcome,
regards, JLG
 

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

Watch MrExcel Video

Forum statistics

Threads
1,127,098
Messages
5,622,683
Members
415,920
Latest member
ExcelNoob28

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top