excel - コピーするセルを決定するためのフィルター。最後に見つかった条件をコピーするようになりました

Question

コードの出力に問題があります。マクロを使用して、ラベルが付けられたいくつかの基準を検索します。

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

私のフィルターは、入力値が見つかった正しいセル値を検索しますが、一致した値を新しいシートにコピーしたいと考えています。現在は、見つかった最後の正しい値をコピーするだけです。誰かがそれを手伝ってくれますか？私が欲しいもの：

• 3 つの条件がすべて一致する場合 (新しいワークシートに 3 つの条件を続けてコピーしたい)
• 2 つの基準が一致する場合 (3 つ目の基準ではなく、2 つの基準を続けてコピーしたい)
• 1 つの基準が一致する場合 (1 つの基準を続けてコピーしたい (2 番目と 3 番目ではない)
• また: 結果のすべての一致は、新しい行を埋める必要があります。説明が少し難しいので、十分な情報を提供できれば幸いです。ご不明な点がございましたら、お気軽にお問い合わせください:)

---

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。これにより、変数を確実に定義できます
2. Excel の行番号を格納するための変数を定義する場合は、代わりにIntegerを使用します。Long
3. の使用は避けてくださいUsedRange。「データ」を持つ実際の範囲を取得します。列 A のみに関心があるため、それを使用して最後の行を見つけます。いつでも.Offset()チェックしCriteria2て使用できますCriteria3
4. 適切な「コメント」でコードにコメントを付けます。私はそれを理解するのに苦労しました。

これはあなたがしようとしていることですか？

コード: (未テスト)

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