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

Question

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

这是 我正在使用的Micro_Enabled_Excel_File 。

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

Excel 数据集：图像

结果会是什么样子：图片

到目前为止我所做的：

1. 创建了一个 Micro 来浏览“范围”和“贸易名称”列，以获取唯一条目并将其复制到另一个名为“代码”的表中。

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

2. 创建了一个 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

3. 创建了一个 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

我相信我需要什么：

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

您能看一下我的代码并让我知道我的错误是什么吗？

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

Answer 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