Excel VBA代码过滤两列并提取数据

Posted 2023-03-10

【中文标题】Excel VBA代码过滤两列并提取数据

【英文标题】：Excel VBA code to filter two columns and extract data

【发布时间】：2020-06-17 11:10:50

【问题描述】：

这是我的第一篇文章，我对此感到非常兴奋。如果我对编码/编程术语不太熟悉，如果我的写作没有意义，我提前道歉。

这是我正在使用的Micro_Enabled_Excel_File。

我有一个包含多列和多行的 excel 文件。随着时间的推移，行数会增加。我正在尝试过滤两列并复制最新/最近的数据点（行）并将其粘贴到新工作表中以创建状态报告。

Excel 数据集：image

结果会是什么样子：image

到目前为止我做了什么：

创建了一个 Micro 来遍历“SCOPE”和“TRADE NAME”列以获取唯一条目并将其复制到另一个名为“Code”的工作表中。

Sub First_COPY_STYLE_TO_REPORT()

    'creating the Report sheet
    Sheets("Report").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Sheets("Status Updates").Select
    Cells.Select
    Selection.Copy
    Sheets("Report").Select
    ActiveSheet.Paste
    Rows("2:1048576").Select
    Application.CutCopyMode = False
    Selection.ClearContents

End Sub

创建了一个 Micro 来为工作表“报告”创建一个模板，该模板最终将填充下一个 Micro 的结果。

Sub Second_COPY_UNIQUE_TO_CODE()

'add title to filter columns in the Code sheet
    Sheets("Code").Select
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Filter1"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Filter2"

'creating the filter criteria also known as scope and trade name

    'Finds Duplicates on SCOPE column and copies it to a new sheet called CODE
    Sheets("Status Updates").Select
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Status Updates")
    Set s2 = Sheets("Code")
    s1.Range(Range("B2"), Range("B2").End(xlDown)).Copy s2.Range("A2")
    s2.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

    'Finds Duplicates on NAME column and copies it to a new sheet called CODE
    Dim s3 As Worksheet, s4 As Worksheet
    Set s3 = Sheets("Status Updates")
    Set s4 = Sheets("Code")
    s1.Range(Range("C2"), Range("C2").End(xlDown)).Copy s2.Range("B2")
    s4.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo

    'Clears formating and autofits column widths
    Sheets("Code").Cells.ClearFormats
    ThisWorkbook.Worksheets("Code").Cells.EntireColumn.AutoFit

End Sub

创建了一个 Micro（不起作用），其中包括两个循环来过滤两列，对第一列进行排序，并将工作表的第二行复制并粘贴到工作表“报告”中。

Sub Third_Generate_Latest_Status_Report()

    Dim a1 As Long, a2 As Long, b1 As Long, b2 As Long
        a1 = Cells.Find("Filter1").Offset(1, 0).Row
        a2 = Cells.Find("Filter1").End(xlDown).Row
        b1 = Cells.Find("Filter2").Offset(1, 0).Row
        b2 = Cells.Find("Filter2").End(xlDown).Row

    Dim g As Long, i As Long

    For g = a1 To a2 'Look up for Filter1 column. Then loop through all criterias.
        ActiveSheet.Range("$C$1:$J$300").AutoFilter Field:=2, Criteria1:=g
        For i = b1 To b2 'Look up for Filter2 column. Then loop through all criterias.
            ActiveSheet.Range("$C$1:$J$300").AutoFilter Field:=3, Criteria1:=i

            'sort the NO column from largest to smallest (to get the latest/most recent update).
            'I have copied this part of the code from the Micro I recorded.
            ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort.SortFields.Clear
            ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort.SortFields.Add2 _
                Key:=Range("C1:C300"), SortOn:=xlSortOnValues, Order:=xlDescending, _
                DataOption:=xlSortNormal
            With ActiveWorkbook.Worksheets("Status Updates").AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
                'I think I need to add code here to copy the row to sheet Report, and run the loop again
            End With
        Next i 'take next value in column Filter2
    Next g 'take next value in column Filter1
End Sub

我认为我需要什么：

工作表“状态更新” - 过滤“范围”列并遍历所有条件。然后， 工作表“状态更新” - 过滤“贸易名称”列并遍历所有条件。 对“NO”列进行排序以获得最新的数据点。 复制第一行数据（即标题后的第一行） 将其粘贴到另一个名为“报告”的工作表中。

能否请您看一下我的代码并告诉我我的错误是什么？

这是我第一次编码/编程/使用 VBA。

【问题讨论】：

This question 是一本好书——如果你是第一次使用 VBA，你可能不会完全理解它，但至少要收藏它并回来。

谢谢@BigBen 我一定会通过它。我对学习和掌握 VBA 非常感兴趣。自从我用我的第一个 VBA-Excel 练习挑战自己 6 个小时以来，我的眼睛今天都亮了。

我赞成这个问题，因为虽然它实际上并没有提出具体问题，但它确实提供了很多我们一直要求的东西：样本数据、预期结果、被问及的代码，并展示自我解决的尝试。很多问题都没有，所以很高兴在这里看到它。继续努力:)

我不得不问，为什么 Mark、John、Dave 和 Steven 不在您提出的结果集中？如果您真的想要一个人的最新唯一性，那么我建议您向上循环数据，并且任何时候您在现有结果中针对大于 1 的两个匹配列找到 sumifs 时，您可以跳过数据行，否则复制它。

@DanDonoghue , Mark 不在 posposed 结果集中的原因是因为 Mark 不是来自 A (Scope) 的 Orange (Trade Name) 的最新更新联系人。 Joe 是 Orange Scope A 上的最后一个人。其他人也是如此。

【参考方案1】：

拥有额外的“代码”表通常只会使事情变得不必要地复杂。并且因为您的“状态更新”表已经按照从最旧的更新到最新的更新进行了排序，我们知道对于任何给定的独特组合，您总是想要底部的更新。如果我们向后循环您的数据（从底行到第一行，这就是 Step -1 所做的），我们可以保证拉动它。

然后使用字典检查唯一组合并提取每个唯一组合的第一个遇到的行（请记住，我们要倒退，所以第一个遇到的行将是最新的更新）并将这些行复制到您的报告表.

最后，这是一个相当适合初学者的代码版本。为了清楚起见，我对它进行了大量评论，以便您可以跟随并理解它的作用。

Sub tgr()

    'Declare and set workbook and worksheet object variables
    Dim wb As Workbook:         Set wb = ActiveWorkbook
    Dim wsUpdt As Worksheet:    Set wsUpdt = wb.Worksheets("Status updates")
    Dim wsRprt As Worksheet:    Set wsRprt = wb.Worksheets("Report")

    'Declare and set a range variable that contains your data
    Dim rUpdateData As Range:   Set rUpdateData = wsUpdt.Range("A2:G" & wsUpdt.Cells(wsUpdt.Rows.Count, "A").End(xlUp).Row)

    'Verify data actually exists
    If rUpdateData.Row < 2 Then Exit Sub    'If the beginning row is the header row, then no data actually exists

    'Use a dictionary object to keep track of unique Scope and Trade Name combos
    Dim hUnqScopeTrades As Object:  Set hUnqScopeTrades = CreateObject("Scripting.Dictionary")

    'Declare your resulting Copy Range variable. This will be used to gather only the range of rows that will be copied over to the Report worksheet
    Dim rCopy As Range

    'Declare a looping variable
    Dim i As Long

    'Loop through each row in your Status Updates data.  Because your updates are already sorted Oldest to Newest, begin at the end and loop backwards to guarantee newest updates are found first
    For i = rUpdateData.Rows.Count To 1 Step -1
        'Verify this Scope/Trade combo hasn't been seen before
        If Not hUnqScopeTrades.Exists(rUpdateData.Cells(i, 2).Value & "|" & rUpdateData.Cells(i, 3).Value) Then
            'This is a newly encountered unique combo
            'Add the combo to the dictionary
            hUnqScopeTrades(rUpdateData.Cells(i, 2).Value & "|" & rUpdateData.Cells(i, 3).Value) = i

            'If this is the first unique combo found, rCopy will be empty, check if that's the case
            If rCopy Is Nothing Then
                'rCopy is empty, add the first found unique combo to it
                Set rCopy = rUpdateData.Cells(i, 1)
            Else
                'rCopy is not empty, add all additional unique combos with the Union method
                Set rCopy = Union(rCopy, rUpdateData.Cells(i, 1))
            End If
        End If
    Next i

    'Clear previous results (if any)
    wsRprt.Range("A1").CurrentRegion.Offset(1).Clear

    'Verify rCopy isn't empty and then copy all rows over
    If Not rCopy Is Nothing Then rCopy.EntireRow.Copy wsRprt.Range("A2")

End Sub

【讨论】：

哇老虎！首先，你的代码就像一个魅力。感谢您花时间评论每一行代码！我从经历中学到了很多。希望有一天我能像你一样写代码。再次感谢您的帮助和支持。我真的很感激。