筛选以确定要复制的单元格，现在复制上次find的条件

我有我的代码的输出麻烦。 我使用macros来search一些标签标签：

Collection = Trim(Range("lblImportCollection").Value) System = Trim(Range("lblImportSystem").Value) Tag = Trim(Range("lblImportTag").Value) 

我的filter确实在searchinput值的地方find正确的单元格值，但我想将匹配的值复制到新的工作表。 现在它只复制find的最后一个正确值。 有人可以帮我吗？ 我想要的是：

• 如果所有三个标准匹配（我想在新的工作表中连续复制3个标准）
• 如果两个标准匹配（我想复制连续两个标准（而不是第三个）
• 如果一个标准匹配（我想复制1条标准连续（所以不是第二和第三）
• 另外：所有产生的匹配都必须填写一个新的行。 我希望我提供了足够的信息，这有点难以解释。 如果你有问题，请告诉我:)

---

 Sub FilterButton() Dim XUsedRange As Range Dim SourceRange As Range, DestRange As Range Dim SrcSheet As Worksheet Dim DestSheet As Worksheet, Lr As Long Dim firstAddress As String Dim c As Range Dim iLastRow As Integer Dim zLastRow As Integer Dim test As String Dim TempRange As Range Dim Collection As String Dim System As String Dim Tag As String With Application .ScreenUpdating = False .EnableEvents = False End With Collection = Trim(Range("lblImportCollection").Value) System = Trim(Range("lblImportSystem").Value) Tag = Trim(Range("lblImportTag").Value) 'fill in the Source Sheet and range Set XUsedRange = Sheets("Imported Data").UsedRange Set ZUsedRange = Sheets("Test").Range("A:C") 'Fill in the destination sheet and find the last known cell Set DestSheet = Sheets("Test") Set SrcSheet = Sheets("Imported Data") 'With the information on the new sheet iLastRow = XUsedRange.End(xlDown).Row zLastRow = ZUsedRange.End(xlUp).Row Set SourceRange = SrcSheet.Range("A2:A" & CStr(iLastRow)) Set DestRange = DestSheet.Range("A2:C" & CStr(zLastRow)) With SourceRange Set c = SourceRange.Find(What:=Collection, SearchOrder:=xlByColumns) If Not c Is Nothing Then firstAddress = c.Address Do MsgBox ("Found " & Collection & " on address:" & c.Address) c.Copy DestRange.PasteSpecial If System = SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row)) Then MsgBox ("The system is " & SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row))) 'DestSheet.Range ("B" & CStr(c.Row) & ":B" & CStr(c.Row)) SrcSheet.Range("B" & CStr(c.Row) & ":B" & CStr(c.Row)).Copy DestRange.PasteSpecial If Tag = SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row)) Then MsgBox ("The tag is" & SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row))) 'DestSheet.Range ("C" & CStr(c.Row) & ":C" & CStr(c.Row)) SrcSheet.Range("C" & CStr(c.Row) & ":C" & CStr(c.Row)).Copy DestRange.PasteSpecial End If End If Set c = SourceRange.FindNext(c) Loop While (Not c Is Nothing) And (c.Address <> firstAddress) Else MsgBox (Collection & " is NOT Found ") End If End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

Answer 1

就像我刚才提到的那样，代码有几个问题

1. 请使用Option Explicit 。 这将确保您定义您的variables
2. 当你定义一个variables是为了存储Excel行号而不是Integer ，使用Long
3. 避免使用UsedRange 。 获取具有“数据”的实际范围。 既然你只关注Col A，那就用它来find最后一行。 我们总是可以使用.Offset()来检查Criteria2和Criteria3
4. 用适当的“评论”评论你的代码。 我很难理解它。

这是你正在尝试？

代码：（UNTESTED）

 Option Explicit Sub FilterButton() Dim SrcSheet As Worksheet, DestSheet As Worksheet Dim SourceRange As Range Dim aCell As Range, bCell As Range Dim iLastRow As Long, zLastRow As Long Dim Collection As String, System As String, Tag As String With Application .ScreenUpdating = False .EnableEvents = False End With '~~> Set your sheet Set DestSheet = Sheets("Test") Set SrcSheet = Sheets("Imported Data") '~~> Find Last Row in Col A in the source sheet With SrcSheet iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row End With '~~> Find Last "Available Row for Output" in Col A in the destination sheet With DestSheet zLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 End With '~~> Set your ranges Set SourceRange = SrcSheet.Range("A2:A" & iLastRow) '~~> Search values Collection = Trim(Range("lblImportCollection").Value) System = Trim(Range("lblImportSystem").Value) Tag = Trim(Range("lblImportTag").Value) With SourceRange '~~> Match 1st Criteria Set aCell = .Find(What:=Collection, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) '~~> If found If Not aCell Is Nothing Then Set bCell = aCell '~~> Copy A:C. Then match for Crit B and Crit C and remove what is not required DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _ SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value '~~> Match 2nd Criteria If aCell.Offset(, 1).Value = System Then '~~> Match 3rd Criteria If aCell.Offset(, 2).Value <> Tag Then _ DestSheet.Range("C" & zLastRow).ClearContents Else DestSheet.Range("B" & zLastRow).ClearContents End If '~~> Increase last row by 1 for output zLastRow = zLastRow + 1 Do Set aCell = .FindNext(After:=aCell) If Not aCell Is Nothing Then If aCell.Address = bCell.Address Then Exit Do '~~> Copy A:C. Then match for Crit B and Crit C DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _ SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value '~~> Match 2nd Criteria If aCell.Offset(, 1).Value = System Then '~~> Match 3rd Criteria If aCell.Offset(, 2).Value <> Tag Then _ DestSheet.Range("C" & zLastRow).ClearContents Else DestSheet.Range("B" & zLastRow).ClearContents End If '~~> Increase last row by 1 for output zLastRow = zLastRow + 1 Else Exit Do End If Loop Else MsgBox Collection & " not Found" End If End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

跟随（从评论）

 Option Explicit Sub FilterButton() Dim SrcSheet As Worksheet, DestSheet As Worksheet Dim SourceRange As Range Dim aCell As Range, bCell As Range Dim iLastRow As Long, zLastRow As Long Dim Collection As String, System As String, Tag As String With Application .ScreenUpdating = False .EnableEvents = False End With '~~> Set your sheet Set DestSheet = Sheets("Test") Set SrcSheet = Sheets("Imported Data") '~~> Find Last Row in Col A in the source sheet With SrcSheet iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row End With '~~> Find Last "Available Row for Output" in Col A in the destination sheet With DestSheet zLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 End With '~~> Set your ranges Set SourceRange = SrcSheet.Range("A2:A" & iLastRow) '~~> Search values Collection = Trim(Range("lblImportCollection").Value) System = Trim(Range("lblImportSystem").Value) Tag = Trim(Range("lblImportTag").Value) With SourceRange '~~> Match 1st Criteria Set aCell = .Find(What:=Collection, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) '~~> If found If Not aCell Is Nothing Then Set bCell = aCell '~~> Copy A:C. Then match for Crit B and Crit C and remove what is not required DestSheet.Range("A" & zLastRow & ":" & "C" & zLastRow).Value = _ SrcSheet.Range("A" & aCell.Row & ":" & "C" & aCell.Row).Value '~~> Match 2nd Criteria If Len(Trim(System)) = 0 Or _ aCell.Offset(, 1).Value <> System Then _ DestSheet.Range("B" & zLastRow).ClearContents '~~> Match 3rd Criteria If Len(Trim(Tag)) = 0 Or _ aCell.Offset(, 2).Value <> Tag Then _ DestSheet.Range("C" & zLastRow).ClearContents '~~> Increase last row by 1 for output zLastRow = zLastRow + 1 Do Set aCell = .FindNext(After:=aCell) If Not aCell Is Nothing Then If aCell.Address = bCell.Address Then Exit Do '~~> Match 2nd Criteria If Len(Trim(System)) = 0 Or _ aCell.Offset(, 1).Value <> System Then _ DestSheet.Range("B" & zLastRow).ClearContents '~~> Match 3rd Criteria If Len(Trim(Tag)) = 0 Or _ aCell.Offset(, 2).Value <> Tag Then _ DestSheet.Range("C" & zLastRow).ClearContents '~~> Increase last row by 1 for output zLastRow = zLastRow + 1 Else Exit Do End If Loop Else MsgBox Collection & " not Found" End If End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub