The correct row is not being highlighted and having appropriate code run on that row

[dpaton05]

This is a strange error as it happens to me sometimes, but not every time. There are two procedures that both are used to identify a row and do something to it. They are called Transfer and LateCancel. They both are meant to cycle through each row, highlighting one row at a time and ask "is this the row?" When the user selects Yes it does something to the row and exits the sub. If No is selected, the highlighting is removed from that row and the next row is highlighted, asking the same question. The subs are initiated from a totals sheet where there 2 spots to enter a date and a request number in some cells. One spot for the Transfer sub to run and one spot for the LateCancel.



The transfer sub is not self explanatory from it's name. This is run on jobs that are to be cancelled.

Order of events

1. I run the sub Transfer from the totals sheet through a command button
2. Row 4 in the July sheet is highlighted
3. I am asked the question, "Is this the job you want to cancel?"
4. I press No and the highlighting moves to row 5 and asks the same question.
5. I press Yes on this row and the row is moved to the cancellations sheet and the sub is exited
6. I run the sub again from the totals sheet
7. Row 4 in the July sheet is highlighted
8. I am asked the question, "Is this the job you want to cancel?"
9. I press No and the highlighting moves to row 5 and asks the same question.
10. I press Yes on this row and the row is moved to the cancellations sheet and the sub is exited
    1. This is exactly what I want it to do so far
11. I now go back to the totals sheet and run the LateCancel sub
12. There is one row left in the July sheet that matches the filters of the autofilter so I would expect that row to be highlighted
13. The header row is highlighted next, where it should have highlighted the remaining row that matches the autofilter. It also asks me the above question.
14. If I keep pressing No, the row is highlighted agan after each time and asked the same question
15. If I press Yes, I get the error message that "No jobs have been selected as a late cancel"
16. I run the LateCancel sub again from the totals sheet and it repeats the steps from step 12

1. I know that this is a sometimes error as if I re-open my file and run the LateCancel sub first, the 3 jobs are cycled though as expected, and I am asked the question each time.
2. If I press Yes or No, it does what it's meant to do

I have been doing some testing and this is the totals sheet, where the information is entered. I leave it the same each time and just run the subs.

CSS Work Allocation Sheet.77.xlsm
	B	C	D	E	F	G
22	Cancelling a job
23	To cancel a job, enter the request number in B25 followed by the date of the proposed job in B27 then press enter and select the cancel the Cancel a job button.
24	Request number
25	95
26	Date
27	5/07/2021
28
29	Late Cancel
30	To enter a job as a late cancel, enter a request number first in B32, followed by the date of the proposed job in B37 then press enter and select the Add Late Cancel button.
31	Request number
32	95
33	Everytime you leave this sheet and return, this will be 3
34	Hours charged for a late cancel
35	3
36	Date
37	5/07/2021
Totals

Cells with Data Validation
Cell	Allow	Criteria
B27	Any value
B25	Any value

I have been testing on the one date 5/07/2021 and here is a monthly sheet in the same document as the above sheet where the data is held.

CSS Work Allocation Sheet.77.xlsm
	A	B	C	D	E	F	G	H	I	J
1	501 CSS July
2
3	Date	Purchase order #	Req #	Name	Service	Requesting Organisation	Caseworker Name	Price ex. GST	GST	Price inc. GST
4	5/07/2021		95		Tutoring			$2.00
5	5/07/2021		95	asdf	Supervised Contact			$219.30	$21.93	$241.23
6	5/07/2021		95	asdf	Supervised contact			$219.30	$21.93	$241.23
July

Cell Formulas
Range	Formula
I5	I5	=IF(E5="Activities",0,H5*0.1)
J5	J5	=I5+H5

Cells with Data Validation
Cell	Allow	Criteria
F6:J6	Any value

This is my Transfer sub

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, n As Integer
                                    Dim RowNumber As Long
                                    Dim RowLine As Range
                                    Application.ScreenUpdating = True
                                    n = 0
                                    For Each RowLine In rng.SpecialCells(xlCellTypeVisible)
                                        ws.Activate
                                        RowLine.EntireRow.Interior.ColorIndex = 6
                                        answer = MsgBox("Is this the job you want to cancel?", vbQuestion + vbYesNo + vbDefaultButton2, "Cancel Job")
                                        RowLine.EntireRow.Interior.ColorIndex = 0
                                        If answer = vbYes Then
                                            'Copy and paste the selected row
                                            RowLine.EntireRow.Copy sht.Range("A" & Rows.Count).End(xlUp).Offset(1)
                                            RowLine.EntireRow.Delete
                                            '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 Then n = n + 1
                                    Next RowLine
                                If n > 0 Then MsgBox " You have chosen not to cancel any of the " & n & " job/s !!"
                                End If
                                
FoundRightJob:

                                .AutoFilter                 ' turn off the autofilter
                        End With
                End If
SkipSheet:
        Next ws


'sh.Range("B25,B27").ClearContents
'Call TurnOnFunctionality
End Sub

This is my LateCancel sub

Sub LateCancel()
        Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, QT As String, wb2 As Workbook, WbPath As String, QTPath As String
        Dim Serv As String, Month As String, Service As String, LCPrice As String, AutoFilterCounter As Long
        Set wb2 = ThisWorkbook
        'QT = "CSS_quoting_tool_29.5.xlsm"
        Set sh = wb2.Worksheets("Totals")

        'values on totals sheet that the user is looking for
        Dim LCReq As String: LCReq = sh.Cells(32, 2).Value
        'Dim LCDt As String: LCDt = sh.Cells(37, 2).Value
        Dim LCDt As String: LCDt = CDate(sh.Cells(37, 2).Value)
        Dim LateCancelHours As String: LateCancelHours = sh.Cells(35, 2).Value
        Dim SheetCounter As Long: SheetCounter = 0
        
        WbPath = ThisWorkbook.Path
        QTPath = ThisWorkbook.Path & "\..\" & "\..\"
'Call TurnOffFunctionality
        'If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(QT) Then Workbooks.Open QTPath & "\" & QT
    
        For Each ws In wb2.Worksheets
                If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
                        With ws.[A3].CurrentRegion
                                'On Error Resume Next
                                'Autofilter the late cancel date enter in B37 with dates in column 1
                                .AutoFilter 1, LCDt
                                'Autofilter the late cancel request number with request numbers in column 3
                                .AutoFilter 3, LCReq
                                
                                '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 SkipNextSheet
                                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 SkipNextSheet
                                End If
                                
                                    With Application.Intersect(.SpecialCells(xlCellTypeVisible), .Offset(1, 0))
                                        'Check if there is a service entered in column 5 of the filtered job.
                                        
                                        If .Areas(1).Cells(1, 5).Value = "" Then
                                            'Display a messagebox with a message and the sheet that has the missing service.
                                            MsgBox "There is a job in the " & ws.Name & " sheet that matches the date and request number but does not have a " & _
                                            "service type. Please add a service type to this job before continuing."
                                            Call TurnOnFunctionality
                                            .AutoFilter
                                            'Cells(32, 2).ClearContents
                                            'Cells(37, 2).ClearContents
                                            Exit Sub
                                        End If
                                        'If the service column, (5), has a value, store the service in the service variable.
                                        Service = .Areas(1).Cells(1, 5).Value
                                    End With
                                
                                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:
                                'No has been selected each time so display a message box and exit sub
                                If RowNumber < 1 Then
                                    MsgBox "No jobs have been selected as a Late Cancel"
                                    .AutoFilter
                                    Exit Sub
                                End If
                                    'Copy data fom the job back to a calculator on the data sheet (this is the code name for sheet2) to calulcate the price again.
                                    With Data
                                        .Cells(30, 1) = CDate(LCDt)
                                        '.Cells(30, 1) = Format(Date, "d/mm/yyyy")
                                        '.Cells(30, 1).NumberFormat = "d/mm/yyyy"
                                        .Cells(30, 2) = Service
                                        'Set the hourly figure in the lateCanel table to be the LateCancelHours variable
                                        .Cells(30, 5) = LateCancelHours
                                        'A late cancel will be charged for 1 staff member attending
                                        'Therefore, set the Staff Req. figure to 1
                                        .Cells(30, 6) = 1
                                    End With
                                    On Error GoTo Price
                                        'Calculates price of late cancel on worksheet so the new price will be copied to the allocation sheet instead of the previous price
                                        Calculate
                                    LCPrice = Data.Cells(30, 8).Value
Price:
                                Select Case Err.Number
                                    Case Is = 13
                                        MsgBox "There is a problem with the spelling of the service type on the " & ws.Name & " sheet for the job that matches " _
                                        & "the date and request number. Please check the spelling and try again."
                                        'Cells(32, 2).ClearContents
                                        'Cells(37, 2).ClearContents
                                        .AutoFilter
                                        Call TurnOnFunctionality
                                        Exit Sub
                                End Select
                                On Error GoTo 0
                                With Application.Intersect(.SpecialCells(xlCellTypeVisible), .Offset(1, 0))
                                    Dim LTCnclDate As String
                                    .Areas(1).Cells(RowNumber, 1).Value = "LT CNCL " & .Areas(1).Cells(1, 1).Value
                                    .Areas(1).Cells(RowNumber, 8).Value = LCPrice
                                    .Areas(1).Cells(RowNumber, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                                    .Areas(1).Cells(RowNumber, 10).Formula = "=RC[-1]+RC[-2]"
                                End With
                                .AutoFilter
                        End With
                End If
SkipNextSheet:
        Next ws
'sh.Range("B32,B37").ClearContents
'Call TurnOnFunctionality
End Sub

Can someone help me work out why this occurs sometimes and not other times please?

 

[dpaton05]

Thanks Michael but this is the logic I want. I just can't get the code to work though.

Sub LateCancel()
        Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, QT As String, WbPath As String, QTPath As String
        Dim Serv As String, Month As String, Service As String, LCPrice As String, answer As String
        Set sh = Sheets("Totals")

        'values on totals sheet that the user is looking for
        Dim LCReq As String: LCReq = sh.Cells(32, 2).Value
        Dim LCDt As String: LCDt = CDate(sh.Cells(37, 2).Value)
        Dim LateCancelHours As String: LateCancelHours = sh.Cells(35, 2).Value
        
        WbPath = ThisWorkbook.Path
        QTPath = ThisWorkbook.Path & "\..\" & "\..\"
        'If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(QT) Then Workbooks.Open QTPath & "\" & QT
For Each ws In Worksheets
    If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
        With ws
            Dim lr As Long, r As Long, SheetCounter As Integer, x As Integer
            lr = .Cells(Rows.Count, "A").End(xlUp).Row
                For r = 4 To lr
                    If .Cells(r, 1).Value = LCDt And .Cells(r, 3).Value = LCReq Then
                                If .Cells(r, 5).Value = "" Then
                                    'Display a messagebox with a message and the sheet that has the missing service.
                                    MsgBox "There is a job in the " & ws.Name & " sheet that matches the date and request number but does not have a " & _
                                    "service type. Please add a service type to this job before continuing."
                                    Exit Sub
                                 End If
                                'If the service column, (5), has a value, store the service in the service variable.
                            Service = .Cells(r, 5).Value
                                ws.Activate
                            Rows(r).Interior.ColorIndex = 6
                            answer = MsgBox("Is this the job you want to apply the late cancel price too?", vbQuestion + vbYesNo + vbDefaultButton2, "Late Cancel Price")
                            Rows(r).Interior.ColorIndex = 0
                                If answer = vbYes Then
                                    With Data
                                    .Cells(30, 1) = CDate(LCDt)
                                    .Cells(30, 2) = Service
                                    'Set the hourly figure in the lateCanel table to be the LateCancelHours variable
                                    .Cells(30, 5) = LateCancelHours
                                    'A late cancel will be charged for 1 staff member attending
                                    'Therefore, set the Staff Req. figure to 1
                                    .Cells(30, 6) = 1
                                If answer = vbNo Then
                                    If r = lr Then
                                        MsgBox "No jobs have been selected"
                                    End If
                                End If
                                On Error GoTo Price
                                    'Calculates price of late cancel on worksheet so the new price will be copied to the allocation sheet instead of the previous price
                                    Calculate
                                LCPrice = .Cells(30, 8).Value
                            End With
Price:
                        If Err.Number = 13 Then
                                MsgBox "There is a problem with the spelling of the service type on the " & ws.Name & " sheet for the job that matches " _
                                & "the date and request number. Please check the spelling and try again."
                                Exit Sub
                        End If
                        On Error GoTo 0
                        Dim LTCnclDate As String
                            .Cells(r, 1).Value = "LT CNCL " & .Cells(r, 1).Value
                            .Cells(r, 8).Value = LCPrice
                            .Cells(r, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                            .Cells(r, 10).Formula = "=RC[-1]+RC[-2]"
                            End If
                        End If
                 Next r
        End With
    End If
SkipNextSheet:

        Next ws
End Sub

If No is pressed and all the rows have been analysed, I want a message box to display of No jobs have been selected. Could you help get it working please?

 

[Michael M]

Sub MM1()
        Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, QT As String, WbPath As String, QTPath As String
        Dim Serv As String, Month As String, Service As String, LCPrice As String, answer As String, n As Integer
        Set sh = Sheets("Totals")

        'values on totals sheet that the user is looking for
        Dim LCReq As String: LCReq = sh.Cells(32, 2).Value
        Dim LCDt As String: LCDt = CDate(sh.Cells(37, 2).Value)
        Dim LateCancelHours As String: LateCancelHours = sh.Cells(35, 2).Value
        
        WbPath = ThisWorkbook.Path
        QTPath = ThisWorkbook.Path & "\..\" & "\..\"
        'If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(QT) Then Workbooks.Open QTPath & "\" & QT
For Each ws In Worksheets
    If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
        With ws
        n = 0
            Dim lr As Long, r As Long
            lr = .Cells(Rows.Count, "A").End(xlUp).Row
                For r = 4 To lr
                    If .Cells(r, 1).Value = LCDt And .Cells(r, 3).Value = LCReq Then
                                If .Cells(r, 5).Value = "" Then
                                    'Display a messagebox with a message and the sheet that has the missing service.
                                    MsgBox "There is a job in the " & ws.Name & " sheet that matches the date and request number but does not have a " & _
                                    "service type. Please add a service type to this job before continuing."
                                    Exit Sub
                                 End If
                                'If the service column, (5), has a value, store the service in the service variable.
                            Service = .Cells(r, 5).Value
                            Rows(r).Interior.ColorIndex = 6
                            answer = MsgBox("Is this the job you want to apply the late cancel price too?", vbQuestion + vbYesNo + vbDefaultButton2, "Late Cancel Price")
                            Rows(r).Interior.ColorIndex = 0
                            If answer = vbNo Then
                            MsgBox "Are you sure you want to skip this job ??", vbQuestion + vbYesNo
                            n = n + 1
                            End If
                                If answer = vbYes Then
                                    With Data
                                    .Cells(30, 1) = CDate(LCDt)
                                    .Cells(30, 2) = Service
                                    'Set the hourly figure in the lateCanel table to be the LateCancelHours variable
                                    .Cells(30, 5) = LateCancelHours
                                    'A late cancel will be charged for 1 staff member attending
                                    'Therefore, set the Staff Req. figure to 1
                                    .Cells(30, 6) = 1
                                On Error GoTo Price
                                    'Calculates price of late cancel on worksheet so the new price will be copied to the allocation sheet instead of the previous price
                                    Calculate
                                LCPrice = .Cells(30, 8).Value
                            End With
Price:
                        If Err.Number = 13 Then
                                MsgBox "There is a problem with the spelling of the service type on the " & ws.Name & " sheet for the job that matches " _
                                & "the date and request number. Please check the spelling and try again."
                                Exit Sub
                        End If
                        On Error GoTo 0
                        Dim LTCnclDate As String
                            .Cells(r, 1).Value = "LT CNCL " & .Cells(r, 1).Value
                            .Cells(r, 8).Value = LCPrice
                            .Cells(r, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                            .Cells(r, 10).Formula = "=RC[-1]+RC[-2]"
                            End If
                        End If
                 Next r
        End With
    End If
    MsgBox "You have chosen not to apply Late Cancel to " & n & " jobs"
SkipNextSheet:
Next ws
End Sub

 

[dpaton05]

I tried running that code and pressed no each time. At the end of the list of jobs that match the criteria, I get the error message of You have chosen not to apply Late Cancel to 4 jobs. This bit is right but I press ok and get another error message of You have chosen not to apply Late Cancel to 0 jobs. I press ok on that error message and the same message box appears with the same question. It does so about 14 times. How do I get rid of the second message box so it won't appear?

 

[Michael M]

Sub MM1()
        Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, QT As String, WbPath As String, QTPath As String
        Dim Serv As String, Month As String, Service As String, LCPrice As String, answer As String, n As Integer
        Set sh = Sheets("Totals")

        'values on totals sheet that the user is looking for
        Dim LCReq As String: LCReq = sh.Cells(32, 2).Value
        Dim LCDt As String: LCDt = CDate(sh.Cells(37, 2).Value)
        Dim LateCancelHours As String: LateCancelHours = sh.Cells(35, 2).Value
        
        WbPath = ThisWorkbook.Path
        QTPath = ThisWorkbook.Path & "\..\" & "\..\"
        'If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(QT) Then Workbooks.Open QTPath & "\" & QT
For Each ws In Worksheets
    If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
        With ws
        n = 0
            Dim lr As Long, r As Long
            lr = .Cells(Rows.Count, "A").End(xlUp).Row
                For r = 4 To lr
                    If .Cells(r, 1).Value = LCDt And .Cells(r, 3).Value = LCReq Then
                                If .Cells(r, 5).Value = "" Then
                                    'Display a messagebox with a message and the sheet that has the missing service.
                                    MsgBox "There is a job in the " & ws.Name & " sheet that matches the date and request number but does not have a " & _
                                    "service type. Please add a service type to this job before continuing."
                                    Exit Sub
                                 End If
                                'If the service column, (5), has a value, store the service in the service variable.
                            Service = .Cells(r, 5).Value
                            Rows(r).Interior.ColorIndex = 6
                            answer = MsgBox("Is this the job you want to apply the late cancel price too?", vbQuestion + vbYesNo + vbDefaultButton2, "Late Cancel Price")
                            Rows(r).Interior.ColorIndex = 0
                            If answer = vbNo Then
                            MsgBox "Are you sure you want to skip this job ??", vbQuestion + vbYesNo
                            n = n + 1
                            End If
                                If answer = vbYes Then
                                    With Data
                                    .Cells(30, 1) = CDate(LCDt)
                                    .Cells(30, 2) = Service
                                    'Set the hourly figure in the lateCanel table to be the LateCancelHours variable
                                    .Cells(30, 5) = LateCancelHours
                                    'A late cancel will be charged for 1 staff member attending
                                    'Therefore, set the Staff Req. figure to 1
                                    .Cells(30, 6) = 1
                                On Error GoTo Price
                                    'Calculates price of late cancel on worksheet so the new price will be copied to the allocation sheet instead of the previous price
                                    Calculate
                                LCPrice = .Cells(30, 8).Value
                            End With
Price:
                        If Err.Number = 13 Then
                                MsgBox "There is a problem with the spelling of the service type on the " & ws.Name & " sheet for the job that matches " _
                                & "the date and request number. Please check the spelling and try again."
                                Exit Sub
                        End If
                        On Error GoTo 0
                        Dim LTCnclDate As String
                            .Cells(r, 1).Value = "LT CNCL " & .Cells(r, 1).Value
                            .Cells(r, 8).Value = LCPrice
                            .Cells(r, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                            .Cells(r, 10).Formula = "=RC[-1]+RC[-2]"
                            End If
                        End If
                 Next r
        End With
    End If
    If n <> 0 Then MsgBox "You have chosen not to apply Late Cancel to " & n & " jobs"
SkipNextSheet:
Next ws
End Sub

 

[Michael M]

This will also name the sheets the Skipped rows are in for each month

Sub MM1()
        Dim ws As Worksheet, sh As Worksheet, sht As Worksheet, QT As String, WbPath As String, QTPath As String
        Dim Serv As String, Month As String, Service As String, LCPrice As String, answer As String, n As Integer
        Set sh = Sheets("Totals")

        'values on totals sheet that the user is looking for
        Dim LCReq As String: LCReq = sh.Cells(32, 2).Value
        Dim LCDt As String: LCDt = CDate(sh.Cells(37, 2).Value)
        Dim LateCancelHours As String: LateCancelHours = sh.Cells(35, 2).Value
        
        WbPath = ThisWorkbook.Path
        QTPath = ThisWorkbook.Path & "\..\" & "\..\"
        'If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(QT) Then Workbooks.Open QTPath & "\" & QT
For Each ws In Worksheets
    If ws.Name <> "Cancellations" And ws.Name <> "Totals" And ws.Name <> "Sheet2" Then
        With ws
        n = 0
            Dim lr As Long, r As Long
            lr = .Cells(Rows.Count, "A").End(xlUp).Row
                For r = 4 To lr
                    If .Cells(r, 1).Value = LCDt And .Cells(r, 3).Value = LCReq Then
                                If .Cells(r, 5).Value = "" Then
                                    'Display a messagebox with a message and the sheet that has the missing service.
                                    MsgBox "There is a job in the " & ws.Name & " sheet that matches the date and request number but does not have a " & _
                                    "service type. Please add a service type to this job before continuing."
                                    Exit Sub
                                 End If
                                'If the service column, (5), has a value, store the service in the service variable.
                            Service = .Cells(r, 5).Value
                            Rows(r).Interior.ColorIndex = 6
                            answer = MsgBox("Is this the job you want to apply the late cancel price too?", vbQuestion + vbYesNo + vbDefaultButton2, "Late Cancel Price")
                            Rows(r).Interior.ColorIndex = 0
                            If answer = vbNo Then
                            MsgBox "Are you sure you want to skip this job ??", vbQuestion + vbYesNo
                            n = n + 1
                            End If
                                If answer = vbYes Then
                                    With Data
                                    .Cells(30, 1) = CDate(LCDt)
                                    .Cells(30, 2) = Service
                                    'Set the hourly figure in the lateCanel table to be the LateCancelHours variable
                                    .Cells(30, 5) = LateCancelHours
                                    'A late cancel will be charged for 1 staff member attending
                                    'Therefore, set the Staff Req. figure to 1
                                    .Cells(30, 6) = 1
                                On Error GoTo Price
                                    'Calculates price of late cancel on worksheet so the new price will be copied to the allocation sheet instead of the previous price
                                    Calculate
                                LCPrice = .Cells(30, 8).Value
                            End With
Price:
                        If Err.Number = 13 Then
                                MsgBox "There is a problem with the spelling of the service type on the " & ws.Name & " sheet for the job that matches " _
                                & "the date and request number. Please check the spelling and try again."
                                Exit Sub
                        End If
                        On Error GoTo 0
                        Dim LTCnclDate As String
                            .Cells(r, 1).Value = "LT CNCL " & .Cells(r, 1).Value
                            .Cells(r, 8).Value = LCPrice
                            .Cells(r, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                            .Cells(r, 10).Formula = "=RC[-1]+RC[-2]"
                            End If
                        End If
                 Next r
        End With
    End If
    If n <> 0 Then MsgBox "You have chosen not to apply Late Cancel to " & n & " jobs in " & ws.Name
SkipNextSheet:
Next ws
End Sub

 

[JLGWhiz]

@Michael M - I'm like you Mike, I don't understand why the selections have to be made manually.The criteria used by the user to select a row to process can just as easily be done by code, IF we knew what that criterian was. It looks like it might be Req#, Date and Service values, but how do they apply in the selection is the question. If @dpaton05 could lay out the steps that need to be taken with the sheets and data in 1, 2, 3 order, I or you could probably whip up code that would work. So far what I see is that After certain jobs have been cancelled, they want to idendtify any remaining jobs that might need to be cancelled, based on the (Unknown) criteria. and put a code in column A of that monthly sheet with the existing date date. Byt U an syre U an leaving some of the process out. I wouldn't need to know what Excel of VBA does, (I can handle that part) what I need to know is what data needs to be looked at, what needs to be copied, deleted, calculated (and the math), etc. In otherwords the input and what is expected as output, with sheet names , data location by column reference, etc. Most (if not all of the data layout is already posted) I just need to be sure of the process before I start trying ot code it.

​

 

[Michael M]

I Believe post #95 has just about covered the requirements, but I'll reserve my comments until @dpaton05 has tested it.
I agree with your comments on the selection process but the OP has specified that they want to look at the row to ensure it IS definitely the row to be used or not !
AND
once this works, I also believe the Transfer Sub can be built into this sub as well !!

 

[JLGWhiz]

Post #96 was a little late, I see Mike has already started with new code.

 

[Michael M]

OMG....we must have boring lives !!!...

 

[dpaton05]

Sure thing. There is a totals sheet that contains 2 cells to enter a date and a request number, defined by LCReq and LCDt.

1. A button is pressed that contains the LateCancel sub
2. If the combination of LCReq and LCDt does not exist for any row of the workbook, let the user know
3. The worksheet containing a combination of LCReq and LCDt for a row must be activated so the user can see which row is the row in question.
4. The row must be highlighted so there is a visual cue for the user and the question must be asked, is this the row?
5. If not, the next row matching the criteria needs to be highlighted and the question asked, is this the row
6. This process must repeat until Yes is pressed or there are no more rows matching the criteria.
7. If no rows are selected, let the user know that no rows have been selected.
8. If Yes is pressed, the alterations need to be made to that row that has been highlighted.
9. The sub then needs to be exited as the correct row for the LateCancel has been found.

I think that is all and I haven't left anything out. Thanks so much for helping me guys. I feel very privileged as I have 2 of the best programmers in the business helping me