dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,392
- Office Version
- 365
- 2016
- Platform
- Windows
I have code that cycles through sheets looking for jobs that are to be cancelled. When they are found some pricing is applied to them and the date is amended to have a LT CNCL in front of it. Jobs are identified using a date and request number. The problem is that there may be multiple instances of the job with the same date and request number. My code allows me to enter a date and request number and cancel it using the above method. It only works if there is one job and doesn't touch any subsequent jobs on the same sheet with the same date and request number. It will however run the code if there are instances on other sheets,
When I execute the procedure, I want the code to zoom in on the first job it encounters with the date and request number and display a message box asking if I want to cancel that job. If I press Yes, apply the LateCancel code to that job and then move on to the next job. If I press no, I want the code to skip the job it has found and go to the next job.
Can someone help me with the above problem please?
Here is my code that cancels the single job.
When I execute the procedure, I want the code to zoom in on the first job it encounters with the date and request number and display a message box asking if I want to cancel that job. If I press Yes, apply the LateCancel code to that job and then move on to the next job. If I press no, I want the code to skip the job it has found and go to the next job.
Can someone help me with the above problem please?
Here is my code that cancels the single job.
VBA Code:
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
'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(1, 1).Value = "LT CNCL " & .Areas(1).Cells(1, 1).Value
.Areas(1).Cells(1, 8).Value = LCPrice
.Areas(1).Cells(1, 9).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
.Areas(1).Cells(1, 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
Last edited: