dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,375
- Office Version
- 365
- 2016
- Platform
- Windows
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
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.
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.
This is my Transfer sub
This is my LateCancel sub
Can someone help me work out why this occurs sometimes and not other times please?
The transfer sub is not self explanatory from it's name. This is run on jobs that are to be cancelled.
Order of events
- I run the sub Transfer from the totals sheet through a command button
- Row 4 in the July sheet is highlighted
- I am asked the question, "Is this the job you want to cancel?"
- I press No and the highlighting moves to row 5 and asks the same question.
- I press Yes on this row and the row is moved to the cancellations sheet and the sub is exited
- I run the sub again from the totals sheet
- Row 4 in the July sheet is highlighted
- I am asked the question, "Is this the job you want to cancel?"
- I press No and the highlighting moves to row 5 and asks the same question.
- I press Yes on this row and the row is moved to the cancellations sheet and the sub is exited
- This is exactly what I want it to do so far
- I now go back to the totals sheet and run the LateCancel sub
- 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
- 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.
- If I keep pressing No, the row is highlighted agan after each time and asked the same question
- If I press Yes, I get the error message that "No jobs have been selected as a late cancel"
- I run the LateCancel sub again from the totals sheet and it repeats the steps from step 12
- 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.
- 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
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, 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 SubThis is my LateCancel sub
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
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 SubCan someone help me work out why this occurs sometimes and not other times please?
