当没有匹配条件的实例存在时修改现有循环
我已经包含了当前运行的基本代码，基本上根据更大的主列表（大约4000行36列）提取特定产品类别的信息。 以前这不是一个问题，因为唯一的代码被列出并且被拉出到单张纸上，都是使用的; 但是，随着时间的推移，一些旧的分配产品号码正在停止使用，不再使用。 所有我试图做的是修改现有的结构，以便它首先通过主清单扫描，以validation是否有任何行匹配的c.Value和d.Value – 如果没有符合匹配的行c .Value和d.Value条件，那么它应该只是在循环内的If语句中执行动作（即删除旧的表单，创build一个新的表单，然后用一个通用的“item code not located”值填充“G2”） ; 如果发现符合c和d.value标准的任何行，则通过正常的过程。
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 在我看来，你总是需要一个新的工作表的Item 。 因此，首先创build新的工作表，然后运行例程以查找并填写来自主工作表的logging的新工作表，并使用variables（ Dim blItmFound As Boolean ）来标记何时find任何logging，并在结束时如果没有findlogging，然后在G2的新工作表中input所需的通用string（请参阅Rem Validate Records ） 。
请注意，我更改了"Item"的variablesItem的值，也改变了这一行：
Loop Until IsEmpty(c.Offset(0, -1))
为了这：
Loop Until c.Value = Empty
有关更多详细信息，请参阅IsEmpty函数
这是你的代码调整：
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
根据我读过的内容，这听起来像是你应该事先在各自的列中search值。 这也假设如果这些条件之一是错误的，你会input你的新代码。 所以你可以做这样的事情：
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
编辑：
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