Run Submacro If It Contains Data

[HTSCF Fareha]

I have what I am sure is a very simple problem that is likely to have an equally simple solution.

I have a workbook ("Triage.xlsm") that has four worksheets named “Data1”, “Data2”, “Data3” and “Data4”. At the moment I have a declared variable which gets utilised in various submacros which I am sure will also be required to answer my query.


Dim ws As Worksheet

There is a submacro called “Markers” that will need to be run on “Data1” or “Data3” if either of them contains data. There are occasions when only “Data1” will contain data, so obviously the submacro needs to only be run on “Data1”. I'd also need it to tell the user if both "Data1" and "Data3" contains no data.

I’m certain that some sort of error checking needs to take place but cannot fathom out how to do the above.

Help will be very much appreciated.

Many thanks!

[Paul_Hossler]

Some ideas

1. Not 'error checking' but more 'validity checking' -- IMHO it's better to prevent an error than to try and recover from one

2. I prefer to avoid global variables as much as possible (Dim ws as Worksheet) and pass such things as a calling parameter (Call Markers(ws))

3. You never defined what 'no data' means, so I went with a completely blank worksheet -- you may have to change that




Option Explicit


Dim ws As Worksheet


Sub Main()
Dim i As Long

For i = 1 To 4
Set ws = Worksheets("Data" & i)
Call Markers(ws)
Next


End Sub


Sub Markers(sht As Worksheet)
Dim M As Double

M = sht.Rows.Count ' avoid overflow
M = M * sht.Columns.Count

If Application.WorksheetFunction.CountBlank(sht.Cells) = M Then
MsgBox ws.Name & " is empty"
Exit Sub
End If

MsgBox "Doing stuff on " & ws.Name
End Sub

[snb]

I have what I am sure is a very simple problem that is likely to have an equally simple solution.

How do you know ?

[HTSCF Fareha]

Some ideas

1. Not 'error checking' but more 'validity checking' -- IMHO it's better to prevent an error than to try and recover from one

2. I prefer to avoid global variables as much as possible (Dim ws as Worksheet) and pass such things as a calling parameter (Call Markers(ws))

3. You never defined what 'no data' means, so I went with a completely blank worksheet -- you may have to change that




Option Explicit


Dim ws As Worksheet


Sub Main()
Dim i As Long

For i = 1 To 4
Set ws = Worksheets("Data" & i)
Call Markers(ws)
Next


End Sub


Sub Markers(sht As Worksheet)
Dim M As Double

M = sht.Rows.Count ' avoid overflow
M = M * sht.Columns.Count

If Application.WorksheetFunction.CountBlank(sht.Cells) = M Then
MsgBox ws.Name & " is empty"
Exit Sub
End If

MsgBox "Doing stuff on " & ws.Name
End Sub




Many thanks for this Paul, but as suggested by snb, this was not quite as simple! :(

I think that I need to provide all the code for my "project"!

I'm still a novice at VBA so am probably commiting some programming problems for myself along the way.

I tried to "manipulate" the code you supplied to fit my requirements and failed miserably.

Hopefully, I've managed to attach my form along with some "dummy" data.

I really do appreciate your help!

[HTSCF Fareha]

I've already spotted a glaring error in this sub. I'd still really appreciate some help please. Thanks!


Private Sub cmdSORHistory_Click()

' Run formatting on History1 and History2 if they contain data


'Dim i As Long

For i = 1 To 2
Set ws = Worksheets("SOR_History" & i)

Next

Dim M As Double

M = ws.Rows.Count ' avoid overflow
M = M * ws.Columns.Count

If Application.WorksheetFunction.CountBlank(ws.Cells) = M Then
MsgBox ws.name & " is empty"
' Exit Sub
End If


' Delete any row containing the words 'Z INFORMATION SHARING' in column D
'Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If InStr(Cells(i, 4), "Z INFORMATION SHARING") Then
'If InStr(Cells(i, 4), "Z INFORMATION SHARING") Or InStr(Cells(i, 4), "Abcdef") Then
Rows(i).Delete
End If
Next

' Perform the basic editing

' Delete first column
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

' Find and remove all instances of ' [O]'
Columns("B:B").Select
Selection.Replace What:=" [O]", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Format date column
Range("$D:$D").NumberFormat = "dd/mm/yyyy"

' Delete columns and rows not required
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.SmallScroll ToRight:=-1
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

' Delete all rows with a date older than eighteen months
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
Dim FilterRange As Range, myDate As Date
myDate = DateSerial(Year(Date) - 1, Month(Date) - 6, Day(Date))
Set FilterRange = _
Range("D8:D" & Cells(Rows.Count, 1).End(xlUp).Row)
FilterRange.AutoFilter Field:=1, Criteria1:="<" & CDbl(myDate)
On Error Resume Next
With FilterRange
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
End With
Err.Clear
Set FilterRange = Nothing
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True

' Add row to top of worksheet
Range("$A$1").EntireRow.Insert

' Add line of text
ActiveSheet.Range("A1").Value = "This is the history shown for the past eighteen months :-" & vbCrLf

'End If
'Next ws

' Message box to show formatting SORHistory complete
Dim answer As Integer

answer = MsgBox("Formatting of SOR History Complete", vbInformation + vbOKOnly, "Triage Hub")
Application.ScreenUpdating = True
End Sub

[snb]

Avoid Application.WorksheetFunction, Application alone suffices.
Avoid 'Select' and 'Activate' in VBA.

[HTSCF Fareha]

Thanks, snb - as per advice I've removed these "words".

Still having an issue with checking the two "pairs" of worksheets for data.

One sub needs to check "Warning_Markers1" and "Warning_Markers2" to see if they contain any data. If either do then the rest of the sub needs to run.
The other sub needs to check "SOR_History1" and "SOR_History2" to see if they contain data, then as above, the rest of the sub needs to run.

The worksheets will either contain data "similar" to the template or be completely empty.

The subs "cmdWarning_Markers" and "cmdSOR_History" are the only two that don't work.

Thanks again!

[snb]

No wonder if procedures like 'Warning_Markers' are lacking.



Private Sub UserForm_Initialize()
For Each it In Sheets
c00 = c00 & " " & it.name
Next

ListBox1.List = Split(Trim(c00))
End Sub

[HTSCF Fareha]

Sorry, snb, I'm not completely understanding. I get that my subs have a different name and your code is to try and address this, but I get a compile error: variable not defined on "it".


' Toggle height of the userform

Private Sub UserForm_Initialize()
For Each it In Sheets
c00 = c00 & " " & it.name
Next

ListBox1.List = Split(Trim(c00))
Dim sht
dHeight = Me.Height
For Each sht In ThisWorkbook.Sheets
Me.ListBox1.AddItem sht.name
Next sht
End Sub

[HTSCF Fareha]

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

[HTSCF Fareha]

Solved the warnings!

Everything works okay, except for when there is no data in Warning_Markers1, but there is data in Warning_Markers2.



Private Sub cmdWarning_Markers_Click()

Dim 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"

Exit Sub
End If

Else

' -------------------------------------------------------
' Check for cells in row A that contain the word 'To'
' If any cells do then delete that column
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Using ActiveSheet but 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

Dim A As Range

Do
Set A = Rows(1).Find(What:="To", LookIn:=xlValues, lookat:=xlPart)
If A Is Nothing Then Exit Do
A.EntireColumn.Delete
Loop

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

[snb]

This is ridiculous code:


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"
Exit Sub
End If

You should replace it by


If ws.usedrange.address <>"$A$1" Then

[HTSCF Fareha]

I'm still learning so I do not know what this is supposed to replace or achieve.

I've changed my code to this, but this is not working. If this is checking the first cell then it won't work as any data being processed will have nothing in that cell.


Private Sub cmdWarning_Markers_Click()

Dim CalcMode As Long, ViewMode As Long

For Each ws In Worksheets
If ws.name Like "Warning_Markers*" Then

If ws.UsedRange.Address <> "$A$1" Then
MsgBox ws.name & " is empty"

Exit Sub
End If

Else

[snb]

If you want to learn start with this first: Excel VBA Programming For Dummies by John Walkenbach | 9781119077398 | Paperback | Barnes & Noble (http://www.barnesandnoble.com/w/excel-vba-programming-for-dummies-john-walkenbach/1101874584)

[HTSCF Fareha]

I've nearly got this working as it should.

If there is no data in "Warning_Markers1" and "Warning_Markers2", then the message box shows this.

If there is data in "Warning_Markers1" and none in "Warning_Markers2", this runs the rest of the sub correctly.

If there is data in "Warning_Markers1" and "Warning_Markers2", then only the data in "Warning_Markers2" is processed by the sub. Running the sub again will then process the data in "Warning_Markers2".

If there is no data in "Warning_Markers1", but there is in "Warning_Markers2" then running the sub, the message box states that there is nothing in "Warning_Markers1" but ignores "Warning_Markers2".

I really need to get this working.


Private Sub cmdWarning_Markers_Click()

Dim CalcMode As Long, ViewMode As Long

For Each ws In Worksheets
If ws.name Like "Warning_Markers*" Then

If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox ws.name & " is empty"

Exit Sub
End If
Else

' -------------------------------------------------------
' Check for cells in row A that contain the word 'To'
' If any cells do then delete that column
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Using ActiveSheet but 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

Dim A As Range

Do
Set A = Rows(1).Find(What:="To", LookIn:=xlValues, lookat:=xlPart)
If A Is Nothing Then Exit Do
A.EntireColumn.Delete
Loop

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

Exit Sub

End If

Next
End Sub

[HTSCF Fareha]

Okay, I can check each ws checking for empty data using


Private Sub cmdWarning_Markers_Click()

Dim CalcMode As Long, ViewMode As Long

Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
With ws
If ws.name Like "Warning_Markers*" Then
If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox ws.name & " is empty"
End If

End If

End With

Next ws
Exit Sub

End Sub

All I need now is for the sub 'Warning_Markers' to run if there is data in "Warning_Markers1" and / or "Warning_Markers2".

I'm thinking that a "Call Warning_Markers" will need to be used?

[snb]

This suffices:

Sub M_snb()
for each it in sheets
if instr(it.name,"Warning") & it.usedrange="1$A$1" then msgbox it.name & " is empty"
next
End Sub

[HTSCF Fareha]

Thanks, SNB.

Just need to get the sub 'Warning_Markers' to run if there is data in worksheets "Warning_Markers1" and / or "Warning_Markers2". Can / should this be incorporated in


Private Sub cmdWarning_Markers_Click()

or should it go at the start of the sub 'Warning_Markers'?

[HTSCF Fareha]

I've changed strategy and tried using an array.

If both "Warning_Markers1" and "Warning_Markers2" have no data in them, then the message box informs the user about each. Good stuff so far!

If "Warning_Markers1" contains data (nothing in "Warning_Markers2"), then running the same sub runs the "ElseIf" part of the code, but in theory looks to run the other sub twice over, thus producing the wrong result.

If there is no data in "Warning_Markers1", but there is in "Warning_Markers2", then there is no message box explaining there is no data for "Warning_Markers1" and ""Warning_Markers2" again seems to run the other sub twice over, again producing the wrong result. :banghead:


Private Sub cmdWarning_Markers_Click()

Set wb = ActiveWorkbook

For Each ws In Sheets(Array("Warning_Markers1", "Warning_Markers2"))
If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox ws.name & " is empty"

ElseIf WorksheetFunction.CountA(Cells) <> 0 Then
Call Warning_Markers
End If

Next
Exit Sub

End Sub






Private Sub Warning_Markers()

Dim CalcMode As Long, ViewMode As Long
' -------------------------------------------------------
' Check for cells in row A that contain the word 'To'
' If any cells do then delete that column
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'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

Dim A As Range

Do
Set A = Rows(1).Find(What:="To", LookIn:=xlValues, lookat:=xlPart)
If A Is Nothing Then Exit Do
A.EntireColumn.Delete
Loop

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

Exit Sub

End Sub

[snb]

Sub M_snb()
for each it in sheets
if instr(it.name,"Warning") & it.usedrange="1$A$1" then y=y+1
next
if y <2 then msgbox "it's only a matter of logic"
End Sub

[HTSCF Fareha]

Sub M_snb()
for each it in sheets
if instr(it.name,"Warning") & it.usedrange="1$A$1" then y=y+1
next
if y <2 then msgbox "it's only a matter of logic"
End Sub

Thanks, snb.

I think I understand the logic, although I cannot fathom what "it" is to be able to make this work.

[snb]

It even works without you understanding the code.

[HTSCF Fareha]

I'd really like to understand it as at the moment, I'm getting a "variable not defined" on 'it'.

I've tried substituting 'it' for the variable I had set for worksheet ('ws'), but this still doesn't work stating that "variable not defined" here


Then y = y + 1

[HTSCF Fareha]

Solved the problem!


Private Sub cmdWarning_Markers_Click()

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Worksheets("Warning_Markers1")
Sheets("Warning_Markers1").Activate

With ws
If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox ws.name & " is empty"

ElseIf WorksheetFunction.CountA(Cells) <> 0 Then
' Perform a check to make sure that the macro hasn't already been run
' If it hasn't, then run it

If Range("B1").Value = "Type" Then

Warning_Markers
ElseIf Range("B1").Value <> "Type" Then
Exit Sub
End If
End If
End With

Set ws = ThisWorkbook.Worksheets("Warning_Markers2")
Sheets("Warning_Markers2").Activate

With ws
If WorksheetFunction.CountA(Cells) = 0 Then
MsgBox ws.name & " is empty"

ElseIf WorksheetFunction.CountA(Cells) <> 0 Then
' Perform a check to make sure that the macro hasn't already been run
' If it hasn't, then run it

If Range("B1").Value = "Type" Then

Warning_Markers
ElseIf Range("B1").Value <> "Type" Then
Exit Sub
End If
End If
End With

Exit Sub

Application.ScreenUpdating = True

End Sub