-1

"Imported Data"一部のデータ（シート= ）をフィルタリングし、シート（）に一致するデータを貼り付けようとしています"Test"。しかし、どういうわけか完全には機能しません。私は前にこの種の質問をしたことがありますが、今3時間試していますが、できません!

私が欲しいもの： - ユーザーが入力できる基準（コレクション、システム、およびタグ）である3つの単一セルがあります - コレクションはMUSTユーザーの入力であり、ユーザーが望む場合は他のセルを空白のままにすることができます。結果は行全体でなければなりません( Column A,B and C) - 1 つ、2 つ、または 3 つの基準が選択された基準に入力されている場合、新しいシートにコピーするにはすべてが一致する必要があります (したがって、1 つの基準が空白のままの場合、結果は 3 つすべての基準になります。ただし、入力されていないものは任意の値にすることができます)。- すべての条件が一致sheet="Imported Data"する場合、列 E の値もシート ( ) にコピーする必要があります"Test"。この列 E の値は、一致した値と同じ行にあるセルである必要があります。ご不明な点がございましたら、お気軽にお問い合わせください...説明するのは少し難しいです。事前に助けてくれてありがとう！これは私が今持っているものです：

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(xlDown).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
            MsgBox System & " Not Found"


            '~~> Match 3rd Criteria
            If Len(Trim(Tag)) = 0 Or _
            aCell.Offset(, 2).Value <> Tag Then _
            DestSheet.Range("C" & zLastRow).ClearContents
            MsgBox Tag & " Not Found"

            If Not DestSheet.Range("B" & zLastRow).ClearContents Or _
            DestSheet.Range("C" & zLastRow).ClearContents Then
            '~~> Copy E:E. Then match for Crit B and Crit C and remove what is not required
             DestSheet.Range("D" & zLastRow & ":" & "D" & zLastRow).Value = _
             SrcSheet.Range("E" & aCell.Row & ":" & "E" & aCell.Row).Value
             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

                    '~~> 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
4

1 に答える 1

0

AdvancedFilter メソッドを使用した方が簡単だと思いますが、データの設定が重要です。

元のデータには 5 つの列 (A:E) があり、ヘッダーは行 1 にあると想定しています。さらに、列 A:C のヘッダーは「コレクション」、「システム」、「タグ」であると想定しています。 「テスト」に重要なものは何もありません (ある場合は、ワークシート全体を「クリア」する代わりに、コードを変更して、関連する部分 (おそらく最初の 4 列) のみをクリアできます。

データ ソースの列 A:C と同じ行 1 の見出しを使用して、インポートされたデータ シートに基準範囲 (3 列、2 行) を設定します。データ検証を使用してエントリを強制できます。または、マクロ自体の中で何かをコーディングすることもできます。または、これらのセルに入力する UserForm を開発することもできます

ユーザーが基準を入力した後、マクロは関連データをコピーする必要があります。3 つの項目がすべて入力されている場合は、列 D が削除されます。それ以外の場合は、列 D:E が削除されます。

データがどのように設定されているかについて間違った仮定をした場合は、フィルターを実行した後にさらに列を削除する必要がある場合があります。

Option Explicit
Sub FilterButton()
    Dim SrcSheet As Worksheet, DestSheet As Worksheet
    Dim SourceRange As Range
    Dim CriteriaRange As Range
    Dim DestRange As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    '~~> Set your sheet
    Set DestSheet = Sheets("Test")
    Set SrcSheet = Sheets("Imported Data")

    '~~> Set your ranges
    Set SourceRange = SrcSheet.Range("a1").CurrentRegion
    Set CriteriaRange = SrcSheet.Range("H1:J2")  'or wherever
    Set DestRange = DestSheet.Range("A1")

'Activate Destination Sheet, Clear it, and run the filter
DestSheet.Activate 'Can only copy filtered data to active sheet
DestSheet.Cells.Clear
SourceRange.AdvancedFilter xlFilterCopy, CriteriaRange, DestRange

'Delete column D always, delete Column E if not three criteria
With DestRange.CurrentRegion
If WorksheetFunction.CountA(CriteriaRange.Rows(2)) <> 3 Then
    Range(.Columns(4), .Columns(5)).Delete
Else
    .Columns(4).Delete (xlToLeft)
End If
End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
于 2013-10-13T17:47:34.933 に答える