I've written what I considered to be a fancy bit of code to classify "work orders" into two categories, but when there is a lot of data, it's no so fancy.
The code acts strangely as it simply appears to pause on this line:
"data.Range(workorders_S & ":" & workorders_S).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=filter, CopytoRange:=WOs.Range("A1"), unique:=True"
To summarize, the macro uses an advanced filter to pull unique work orders into a list which it then cycles through. Another Advanced filter is created using the current work order number and if the macro finds a specific job number (many jobs in a work order) it classifies all of the jobs in the entire work order as PM and if not, it classifies it all as repair.
It works fine most of the time, but when there is a huge amount of data if simply stops on that line, when I try step past it in debug mode, it doesn't move.I have to drag it to the next line then carry on.
Can anyone see why it would do this?
Thanks
The code acts strangely as it simply appears to pause on this line:
"data.Range(workorders_S & ":" & workorders_S).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=filter, CopytoRange:=WOs.Range("A1"), unique:=True"
To summarize, the macro uses an advanced filter to pull unique work orders into a list which it then cycles through. Another Advanced filter is created using the current work order number and if the macro finds a specific job number (many jobs in a work order) it classifies all of the jobs in the entire work order as PM and if not, it classifies it all as repair.
It works fine most of the time, but when there is a huge amount of data if simply stops on that line, when I try step past it in debug mode, it doesn't move.I have to drag it to the next line then carry on.
Can anyone see why it would do this?
Thanks
Code:
Sub pmRepair()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Application.DisplayAlerts = False
Application.DisplayAlerts = True
Set toolsWB = ThisWorkbook
PMFile = Application.GetOpenFilename
If PMFile = "False" Then
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox ("No file selected, can not continue")
End
End If
Application.StatusBar = "Initializing macro"
Set wb = Workbooks.Open(PMFile)
On Error GoTo Err1:
Set data = wb.Worksheets("Data")
On Error GoTo 0
Application.StatusBar = "Adding Temporary Worksheets"
Set ws = wb.Worksheets.Add
ws.name = "Temp"
Set WOs = wb.Worksheets.Add
WOs.name = "WorkOrders"
Set FilterWS = wb.Worksheets.Add
FilterWS.name = "AdFilt"
FilterWS.Range("A1").Value = "Work Order"
Set filter = FilterWS.Range("A1:A2")
Application.StatusBar = "Searching Data for Job Codes"
'search for column with job codes in
JobCol = GetColumnNumber("Job Code")
If JobCol = 0 Then
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("Job Code Column needs to be titled Job Code before this macro can continue, please update, save close and start again")
End
End If
JobCol_S = ConvertToLetter(JobCol)
Application.StatusBar = "Searching Data for Work Orders"
'Find work order column
workorders = GetColumnNumber("Work Order")
If workorders = 0 Then
workorders = GetColumnNumber("Work Orders")
If workorders = 0 Then
workorders = GetColumnNumber("WO")
If workorders = 0 Then
workorders = GetColumnNumber("WOs")
If workorders = 0 Then
workorders = GetColumnNumber("Work Order #")
If workorders = 0 Then
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("Please ensure the Work Orders Column is named Work Order, save and close and start again")
ws.Delete
WOs.Delete
FilterWS.Delete
End
End If
End If
End If
End If
End If
workorders_S = ConvertToLetter(workorders)
Application.StatusBar = "Checking Filter"
'Ensure work order filter is correct
If data.Range(workorders_S & "1").Value <> FilterWS.Range("A1").Value Then
FilterWS.Range("A1").Value = data.Range(workorders_S & "1").Value
Application.EnableEvents = True
Application.ScreenUpdating = True
If MsgBox("Work Orders column was not as expected, is the column with work orders titled " & data.Range(workorders_S & "1").Value & " ?", vbYesNo) = vbNo Then
MsgBox ("Please rename the work orders column to Work Order and ensure no other columns start with that name")
Application.DisplayAlerts = False
FilterWS.Delete
WOs.Delete
ws.Delete
Application.DisplayAlerts = True
End
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
End If
Application.StatusBar = "Add Results Column"
'Find Last Column
LastCol = data.Cells(1, Columns.Count).End(xlToLeft).Column
'Load Result Column
If GetColumnNumber("PM / Repair") = 0 Then
data.Cells(1, LastCol + 1).Value = "PM / Repair"
LastCol = LastCol + 1
LastCol_S = ConvertToLetter(LastCol)
ResultCol = LastCol
ResultCol_S = LastCol_S
Else
GetColumnNumber ("PM / Repair")
End If
Application.StatusBar = "Add References"
'Load Reference column
data.Cells(1, LastCol + 1).Value = "Reference"
LastCol = LastCol + 1
LastCol_S = ConvertToLetter(LastCol)
RefCol = LastCol
RefCol_S = LastCol_S
data.Cells(2, LastCol).Value = 2
data.Cells(3, LastCol).Value = 3
data.Range(LastCol_S & "2:" & LastCol_S & "3").AutoFill data.Range(LastCol_S & "2:" & LastCol_S & data.Cells(data.Cells.Rows.Count, "A").End(xlUp).Row)
Application.StatusBar = "Identify Work Orders to Process"
'copy WO's to WO tab
:crash:data.Range(workorders_S & ":" & workorders_S).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=filter, CopytoRange:=WOs.Range("A1"), unique:=True:crash:
For i = 2 To WOs.Cells(WOs.Rows.Count, 1).End(xlUp).Row
FilterWS.Range("A2").Value = WOs.Range("A" & i)
data.Range("A1:" & LastCol_S & data.Cells(data.Cells.Rows.Count, "A").End(xlUp).Row).AdvancedFilter xlFilterCopy, filter, ws.Range("A1")
For i2 = 2 To ws.Cells(ws.Cells.Rows.Count, 1).End(xlUp).Row
If ws.Range(JobCol_S & i2).Value = "06-24-AHI" Or ws.Range(JobCol_S & i2).Value = "06-24-ANN" Or ws.Range(JobCol_S & i2).Value = "06-24-AVI" Or ws.Range(JobCol_S & i2).Value = "06-24-BIW" Or ws.Range(JobCol_S & i2).Value = "06-24-CVI" Or ws.Range(JobCol_S & i2).Value = "06-24-MAJ" Or ws.Range(JobCol_S & i2).Value = "06-24-MIN" Or ws.Range(JobCol_S & i2).Value = "06-24-SIX" Or ws.Range(JobCol_S & i2).Value = "06-36-MAJ" Then
For i3 = 2 To ws.Cells(ws.Cells.Rows.Count, 1).End(xlUp).Row
data.Range(ResultCol_S & ws.Range(RefCol_S & i3).Value) = "PM"
Next i3
GoTo jumpi
Else
'do nothing
data.Range(ResultCol_S & ws.Range(RefCol_S & i2).Value) = "Repair"
End If
'data.ShowAllData
Next i2
jumpi:
ws.UsedRange.Clear
DoEvents
Application.StatusBar = "Executing " & i & " of " & WOs.Cells(WOs.Rows.Count, 1).End(xlUp).Row & " Work orders"
Next i
Application.DisplayAlerts = False
FilterWS.Delete
WOs.Delete
ws.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.StatusBar = False
Application.DisplayAlerts = True
data.Cells(1, RefCol).EntireColumn.Delete
wb.Save
MsgBox ("Process completed")
End
Err1:
Set data = wb.Worksheets(1)
Resume Next
End Sub
Sub Progresscode()
'code to follow in later version
End Sub
Private Function GetColumnNumber(name As String) As Long
Dim play As Variant, j As Long, Current As Long
Set play = data.Range("1:1")
For i = 1 To data.Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(play(1, i), name) > 0 Then
Current = i
End If
Next i
GetColumnNumber = Current
End Function
Function ConvertToLetter(iCol As Long) As String
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
Last edited by a moderator: