I've gone with a slightly different approach and am concentrating on just one sub -
Private Sub cmdWarning_Markers_Click()
Dim Firstcolumn As Long, Lastcolumn As Long, Lcolumn As Long, CalcMode As Long, ViewMode As Long
For Each ws In Worksheets
If ws.name Like "Warning_Markers*" Then
Dim M As Double
M = ws.Rows.Count ' avoid overflow
M = M * ws.Columns.Count
If Application.CountBlank(ws.Cells) = M Then
MsgBox ws.name & " is empty"
End If
Else
' -------------------------------------------------------
' Check for cells in column D that contain the word 'To'
' If any cells do then delete column D
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'We use the ActiveSheet but you can replace this with
'Sheets("MySheet")if you want
With ActiveSheet
'If you are in Page Break Preview Or Page Layout view go
'back to normal view, we do this for speed
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
'Turn off Page Breaks - we do this for speed
.DisplayPageBreaks = False
' Set the first and last column to loop through
Firstcolumn = 3
Lastcolumn = 5
' We loop from Lastcolumn to Firstcolumn (right to left)
For Lcolumn = Lastcolumn To Firstcolumn Step -1
' We check the values in the D column in this example
With Cells(Lcolumn, "D")
If Not IsError(.Value) Then
' This will delete each row with the Value "To"
' in Column D (not case sensitive)
If LCase(.Value) = LCase("To") Then .EntireColumn.Delete
End If
End With
Next Lcolumn
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
' -------------------------------------------------------
' Format date in column C
Range("$C:$C").NumberFormat = "dd/mm/yyyy"
' Delete first three rows
Rows("1:3").Delete
' -------------------------------------------------------
' Sort Warning Markers, firstly by values in array, then by date order
Dim rData As Range, rData1 As Range, rData2 As Range
Dim r As Long, i As Long, iLastSort As String
Dim arySorts As Variant
Dim sLastSort As String
arySorts = Array("Domestic abuse/violence", "Violent", "Weapons", "Drugs", "Offends on bail") ' starts at 0
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
Application.AddCustomList ListArray:=arySorts
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=Application.CustomListCount
.SortFields.Add Key:=rData1.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
.SetRange rData
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
.SortFields.Clear
End With
Set rData2 = Nothing
With rData
'see which last sort is in data
For i = UBound(arySorts) To LBound(arySorts) Step -1
iLastSort = -1
On Error Resume Next
iLastSort = Application.WorksheetFunction.Match(arySorts(i), Application.WorksheetFunction.Index(rData, 0, 2), 0)
On Error GoTo 0
'found custom sort value
If iLastSort > -1 Then
sLastSort = LCase(arySorts(i))
Exit For
End If
Next i
End With
'custom sort value found
If Len(sLastSort) > 0 Then
With rData
For r = .Rows.Count To 3 Step -1
If LCase(.Cells(r, 2).Value) = sLastSort Then
Set rData2 = .Cells(r + 1, 1)
Set rData2 = Range(rData2, rData2.End(xlDown).End(xlToRight))
Exit For
End If
Next
End With
'MsgBox rData2.Address
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
.SetRange rData2
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
.SortFields.Clear
End With
End If
Application.DeleteCustomList ListNum:=Application.CustomListCount
' -------------------------------------------------------
' Delete first column
Columns(1).Delete
' Add row to top of worksheet
Range("$A$1").EntireRow.Insert
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
' Add line of text to cell A1
ActiveSheet.Range("A1").Value = "These are the warning markers shown :-" & vbCrLf
' Message box to show formatting complete
Dim answer As Integer
answer = MsgBox("Formatting of Warning Markers Complete", vbInformation + vbOKOnly, "Triage Hub")
Application.ScreenUpdating = True
End If
Next ws
lbl_Exit:
Exit Sub
End Sub
If I have data in Warning_Markers1, then it formats okay and puts up the message box to tell me that Warning_Markers2 is empty, but then when I click okay, it immediately shows an error on this line with Runtime error 91: Object variable or With block variable not set.
If I have data in Warning_Markers1 and Warning_Markers2, then it goes straight to the same line and error.
.SortFields.Add Key:=rData2.Columns(3), SortOn:=xlSortOnValues, Order:=xlDescending
Reply With Quote
Originally Posted by Paul_Hossler
