Sub Del_Rows_n_Cols_on_Condition_AllWS_AllWB_Same_Folder_Final_Revised()
'http://www.vbaexpress.com/forum/showthread.php?48681-Selecting-and-deleting-rows-based-on-criteria
Dim wb As Workbook, ws As Worksheet
Dim FirstRowQ As Variant
Dim i As Long, FR As Long, LR As Long, LC As Long, calc As Long
Dim fName As String, fPath As String
With Application
.DisplayAlerts = False
.EnableEvents = False
.AskToUpdateLinks = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
fPath = "C:\Users\test\" 'change to suit. include final \
fName = Dir(fPath & "*.xls*")
Do While fName <> ""
Set wb = Workbooks.Open(fPath & fName)
For i = 1 To wb.Worksheets.Count
If Worksheets(i).Visible Then
Worksheets(i).Select
Exit For
End If
Next i
FirstRowQ = MsgBox(wb.Name & vbLf & vbLf & "Is the first row the same in each worksheet?", vbYesNoCancel, "First Row Decision")
If FirstRowQ = vbYes Then
FR = Application.InputBox("Please Select the First Row of the Range", "First Row Selection", Type:=8).Row
For Each ws In wb.Worksheets
With ws
On Error Resume Next
If .Visible = True Then
LR = .Cells.Find("Source", , , xlPart, xlByRows, xlPrevious).Row - 1
LC = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
For i = LR To FR Step -1
If Application.CountA(.Rows(i)) = 0 Then
.Rows(i).Delete
Else
For Each it In Array("NE", "NW", "YH", "EM", "WM", "E", "LL", "IL", "OL", "SE", "SW")
If Application.CountIf(.Rows(i), it) > 0 Then .Rows(i).Delete
Next
End If
Next
For i = LC To 1 Step -1
If Application.CountA(.Columns(i)) = 0 Then .Columns(i).Delete
Next
.Rows.AutoFit
End If
End With
Next ws
ElseIf FirstRowQ = vbNo Then
For Each ws In wb.Worksheets
With ws
If .Visible = True Then
.Activate
FR = Application.InputBox("Please Select the First Row of the Range", "First Row Selection", Type:=8).Row
LR = .Cells.Find("Source", , , xlPart, xlByRows, xlPrevious).Row - 1
LC = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
For i = LR To FR Step -1
If Application.CountA(.Rows(i)) = 0 Then
.Rows(i).Delete
Else
For Each it In Array("NE", "NW", "YH", "EM", "WM", "E", "LL", "IL", "OL", "SE", "SW")
If Application.CountIf(.Rows(i), it) > 0 Then .Rows(i).Delete
Next
End If
Next
For i = LC To 1 Step -1
If Application.CountA(.Columns(i)) = 0 Then .Columns(i).Delete
Next
.Rows.AutoFit
End If
End With
Next ws
Else
MsgBox "You cancelled the code execution. Quitting...", vbOKOnly, "QUIT"
wb.Close SaveChanges:=False
Exit Sub
End If
wb.Close SaveChanges:=True
fName = Dir()
Loop
With Application
.DisplayAlerts = True
.EnableEvents = True
.AskToUpdateLinks = True
.Calculation = calc
End With
End Sub