Modifying existing loop when no instance of matched criteria is present - vba

Question

I've included the base code that currently runs to essentially pull out info for a specific product category based on a larger master listing (approx. 4000 lines by 36 columns). Previously this was not an issue, as the only codes listed and pulled out to individual sheets, were all is use; over time though, some of the older assigned product numbers are being discontinued and no longer in use. All I'm trying to do is modify the existing structure so that it first does a sweep through the master listing to verify whether or not any lines match the c.Value and d.Value - if there are no lines that meet the matching c.Value and d.Value criteria then it should just perform the action in the If statement inside the loop (ie. delete the old sheet, make a new one, and populate "G2" with a generic "item code not located" value); if any lines are found that meet the c and d.value criteria then it goes through the normal process.
Option Explicit
Sub Item()
CreateDeptReport "Item"
End Sub
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
On Error GoTo Err_Execute
Application.ScreenUpdating = False
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
LCopyToRow = 11
Do
If c.Value = 2516 And d.Value = "37A" And Not e.Value = "T1" And Not e.Value = "T3" Then
If shtRpt Is Nothing Then
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Item").Delete
Application.DisplayAlerts = True
On Error GoTo 0
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = "Item"
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
End If
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until IsEmpty(c.Offset(0, -1))
ThisWorkbook.Worksheets("Item").Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

Answer 1

It seems to me that you always want a new Worksheet for the Item.
So create the new worksheet first, then run the routine to find and fill the new worksheet with the records from the Master worksheet and use a variable (Dim blItmFound As Boolean) to flag when any record is found and at the end if there where no records found then enter in the new worksheet at G2 the generic string you want (see Rem Validate Records).
Please note that I changed "Item" for the value of the Variable Item and also changed this line:
Loop Until IsEmpty(c.Offset(0, -1))
for this:
Loop Until c.Value = Empty
for more details see IsEmpty Function
This is your code adjusted:
Sub CreateDeptReport(Item As String)
Dim shtRpt As Excel.Worksheet, shtMaster As Excel.Worksheet, shtPrevious As Excel.Worksheet
Dim LCopyToRow As Long
Dim LCopyToCol As Long
Dim LastRow As Long
Dim arrColsToCopy
Dim c As Range, d As Range, e As Range, x As Integer
Dim blItmFound As Boolean
arrColsToCopy = Array(1, 8, 3, 7, 9, 10, 39, 19, 24, 25, 27, 29, 33, 34, 35)
Application.ScreenUpdating = False
Set shtMaster = ThisWorkbook.Sheets("CurrentMaster")
Set shtPrevious = ThisWorkbook.Sheets("PreviousMaster")
Set c = shtMaster.Range("AI5")
Set d = shtMaster.Range("H5")
Set e = shtMaster.Range("X5")
Rem Delete Item Worksheet
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets(Item).Delete
Application.DisplayAlerts = True
On Error GoTo Err_Execute
Rem Add New Item Worksheet
ThisWorkbook.Sheets("Template").Visible = xlSheetVisible
ThisWorkbook.Sheets("Template").Copy After:=shtPrevious
Set shtRpt = ThisWorkbook.Sheets(shtPrevious.Index + 1)
shtRpt.Name = Item
Range("G2").Value = Item
Range("C3").Value = Date
ThisWorkbook.Sheets("Template").Visible = xlSheetVeryHidden
Rem Get Records from Master
LCopyToRow = 11
blItmFound = False
Do
If c.Value = 2516 _
And d.Value = "37A" _
And Not e.Value = "T1" _
And Not e.Value = "T3" Then
blItmFound = True
LCopyToCol = 1
shtRpt.Cells(LCopyToRow, LCopyToCol).EntireRow.Insert Shift:=xlDown
For x = LBound(arrColsToCopy) To UBound(arrColsToCopy)
shtRpt.Cells(LCopyToRow, LCopyToCol).Value = c.EntireRow.Cells(arrColsToCopy(x)).Value
LCopyToCol = LCopyToCol + 1
Next x
LCopyToRow = LCopyToRow + 1
End If
Set c = c.Offset(1, 0)
Set d = d.Offset(1, 0)
Set e = e.Offset(1, 0)
Loop Until c.Value = Empty
Rem Validate Records
Select Case blItmFound
Case True
ThisWorkbook.Worksheets(Item).Rows("10:10").Delete
LastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
If LastRow <> 0 Then
Rows(LastRow).EntireRow.Delete
End If
Case False
ThisWorkbook.Worksheets(Item).Range("G2").Value = "Item: [" & Item & "] code not located"
End Select
Range("A9").Select
Application.ScreenUpdating = True
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub

Answer 2

Based on what I've read, it sounds like you should just search for the values in their respective columns beforehand. This is also assuming that if one of those conditions is false, you'll enter your new code. So you could do something like:
Set cRange = shtMaster.Columns("AI:AI")
Set dRange = shtMaster.Columns("H:H")
If cRange.Find(2516) Is Nothing Or dRange.Find("37A") Is Nothing Then
'do code when either one of these conditions is false
Else
'both values are found in their respective columns
'do existing code
EDIT:
Set rng = Range("AI:AI")
Set origCell = rng.Find(2516)
Set currCell = origCell
Do
Set currCell = rng.FindNext(currCell)
If shtMaster.Range("H" & currCell.Row).Value = "37A" Then
boolMatchingPair = True
Exit Do
End If
Loop While currCell.Row <> origCell.Row
If boolMatchingPair = True
'found match
Else
'no match