Excel 筛选以确定要复制的主单元格，现在复制上次找到的条件_Excel_Filter_Copy_Vba

Excel 筛选以确定要复制的主单元格，现在复制上次找到的条件

excel filter vba

Excel 筛选以确定要复制的主单元格，现在复制上次找到的条件,excel,filter,copy,vba,Excel,Filter,Copy,Vba,我的代码输出有问题。Im使用宏搜索标记为以下内容的某些条件： Collection = Trim(Range("lblImportCollection").Value) System = Trim(Range("lblImportSystem").Value) Tag = Trim(Range("lblImportTag").Value) 我的过滤器会搜索找到输入值的正确单元格值，但我希望将匹配的值复制到新的工作表中。现在它只复制找到的最后一个正确值。有人能帮我

我的代码输出有问题。Im使用宏搜索标记为以下内容的某些条件：

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

我的过滤器会搜索找到输入值的正确单元格值，但我希望将匹配的值复制到新的工作表中。现在它只复制找到的最后一个正确值。有人能帮我吗？我想要的是：

如果三个条件都匹配（我想在新工作表上复制一行中的三个条件）
如果两个条件匹配（我想复制一行中的两个条件（而不是第三个）
如果一个条件匹配（我想复制一行中的1个条件（因此不是第二个和第三个）
另外：所有结果匹配必须填充新行。我希望我提供了足够的信息，这有点难以解释。如果你有问题，请告诉我：）

子过滤器按钮（）
将范围变暗为范围
变暗源范围作为范围，减小范围作为范围
将工作表作为工作表
将图纸尺寸标注为工作表，Lr长度标注为
将第一个地址设置为字符串
调光范围
Dim iLastRow作为整数
Dim zLastRow作为整数
作为字符串的Dim测试
暗温度范围作为范围
将集合设置为字符串
作为字符串的Dim系统
作为字符串的Dim标记
应用
.ScreenUpdate=False
.EnableEvents=False
以
集合=修剪（范围（“lblImportCollection”）.值）
系统=微调（范围（“lblImportSystem”）.值）
标记=修剪（范围（“lblImportTag”）.值）
'填写源表和范围
设置XUsedRange=Sheets（“导入的数据”）.UsedRange
设置ZUsedRange=板材（“测试”）。范围（“A:C”）
'填写目标工作表并找到最后一个已知的单元格
设置图纸=图纸（“测试”）
Set SrcSheet=图纸（“导入的数据”）
“新工作表上的信息
iLastRow=XUsedRange.End（xlDown.Row）
zLastRow=ZUsedRange.End（xlUp）.Row
Set SourceRange=SrcSheet.Range（“A2:A”和CStr（iLastRow））
设置DestRange=DestSheet.Range（“A2:C”和CStr（zLastRow））
使用SourceRange
Set c=SourceRange.Find（What:=Collection，SearchOrder:=xlByColumns）
如果不是，那么c什么都不是
firstAddress=c.地址
做
MsgBox（“在地址：&c.address上找到”&Collection&）
c、 抄袭
DestRange.PasteSpecial
如果System=SrcSheet.Range（“B”和CStr（c.Row）&“：B”和CStr（c.Row）），则
MsgBox（“系统为”&SrcSheet.Range（“B”&CStr（c.Row）&“：B”&CStr（c.Row）））
'DestSheet.Range（“B”和CStr（c.Row）以及“：B”和CStr（c.Row））
SrcSheet.范围（“B”和CStr（c.Row）和“：B”和CStr（c.Row））。副本
DestRange.PasteSpecial
如果Tag=SrcSheet.Range（“C”和CStr（C.Row）&“：C”和CStr（C.Row）），则
MsgBox（“标记为”&SrcSheet.Range（“C”&CStr（C.Row）&“：C”&CStr（C.Row）））
'DestSheet.Range（“C”和CStr（C.Row）以及“：C”和CStr（C.Row））
SrcSheet.范围（“C”和CStr（C.Row）和“：C”和CStr（C.Row））。副本
DestRange.PasteSpecial
如果结束
如果结束
Set c=SourceRange.FindNext（c）
循环While（非c为Nothing）和（c.AddressFirstAddress）
其他的
MsgBox（未找到集合&“未找到”）
如果结束
以
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头

就像我提到的，代码有几个问题

请使用

选项Explicit

。这将确保您定义变量

定义用于存储Excel行号的变量时，请使用

Long

避免使用

UsedRange

。获取包含“数据”的实际范围。因为您只关心列A，所以使用它来查找最后一行。我们始终可以使用

.Offset（）

检查

标准2

和

标准3

用适当的“注释”注释代码。我很难理解它

这就是你想要的吗

代码：（未经测试）

选项显式
子过滤器按钮（）
将图纸作为工作表，将图纸作为工作表
将源范围变暗为范围
Dim aCell作为范围，B cell作为范围
暗淡的伊拉斯特罗一样长，兹拉斯特罗一样长
Dim集合作为字符串、系统作为字符串、标记作为字符串
应用
.ScreenUpdate=False
.EnableEvents=False
以
“~~>把床单放好
设置图纸=图纸（“测试”）
Set SrcSheet=图纸（“导入的数据”）
“~~>查找源工作表中A列的最后一行
带SrcSheet
iLastRow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
以
“~~>在目标工作表的A列中查找最后一个“可供输出的行”
带床单
zLastRow=.Range（“A”&.Rows.Count）.End（xlUp）.Row+1
以
“~~>设置您的范围
Set SourceRange=SrcSheet.Range（“A2:A”和iLastRow）
“~~>搜索值
集合=修剪（范围（“lblImportCollection”）.值）
系统=微调（范围（“lblImportSystem”）.值）
标记=修剪（范围（“lblImportTag”）.值）
使用SourceRange
“~~>符合第一个条件
Set aCell=.Find（What:=集合，LookIn:=xlValues_
查看：=xlother，搜索顺序：=xlByRows，搜索方向：=xlNext_
MatchCase:=False，SearchFormat:=False）
“~~>如果找到
如果不是的话，亚塞尔什么都不是
设置bCell=aCell
“~~>复制A:C。然后匹配临界值B和临界值C，并删除不需要的内容
DestSheet.Range（“A”&zLastRow&“：”与“C”&zLastRow）。值=_
SrcSheet.Range（“A”和aCell.Row&“：”和“C”和aCell.Row）.Value
“~~>符合第二个条件
如果aCell.Offset（，1）.Value=系统，则
“~~>符合第三个条件
如果aCell.Offset（，2）.V
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

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