基于Match函数实现每日赛事数据汇总的VBA解决方案（替代Vlookup/Xlookup）

需求 #

基于每日数据表制作赛事场次与获胜情况的汇总表，每日数据需放置在当前表格A列起始的区域。

问题场景 #

使用VLOOKUP和XLOOKUP函数时出现语法错误，无法实现汇总逻辑。

解决方案 #

调整表格布局，改用MATCH函数实现汇总。以下是经过验证可正常运行的VBA代码：

Sub won()
    Dim rw As Long, rc As Long, rr As Long, r As Long, C As Long, lr2 As Long
    Dim rng As Range, rng2 As Range, sh As Worksheet
    
    Set sh = Sheets("Sheet4")
    lr2 = Range("A1").End(xlDown).Row 'rows of input data
    
    Columns("A:C").Select
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add2 Key:=Range( _
        "A2:A" & lr2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add2 Key:=Range( _
        "B2:B" & lr2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range("A1:C" & lr2)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set rng = Range("B2:B" & lr2) 'Cells(Rows.Count, "A").End(xlUp).Row)
    Set rng2 = Range("A2:A" & lr2) 'Cells(Rows.Count, "A").End(xlUp).Row)
    With sh
        lastcol = Unique(rng) ' to know number of columns appearing in report
        TickerCount = Unique(rng2) ' to know the number of Tickers
        rr = Application.Match("Name", .Columns(1), 0)
        rc = .Cells(rr, Columns.Count).End(xlToLeft).Column + 2
        .Cells(rr, rc + 1) = .Cells(rr + 1, 2).Value2
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
        For rw = rr + 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If IsError(Application.Match(.Cells(rw, 1).Value2, .Columns(rc), 0)) Then
                .Cells(Rows.Count, rc).End(xlUp).Offset(1, 0) = .Cells(rw, 1).Value2
            End If
            If IsError(Application.Match(.Cells(rw, 2).Value2, .Cells(rr, rc).Resize(1, (lastcol + 10)), 0)) Then
                .Cells(rr, .Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 2).Value2
            End If

            r = Application.Match(.Cells(rw, 1).Value2, .Columns(rc), 0)
            C = Application.Match(.Cells(rw, 2).Value2, .Rows(rr), 0)
            .Cells(r, C) = .Cells(rw, 3).Value ' & "_" & .Cells(rw, 2).Value
        Next rw
    End With
    Dim startColumn As Integer
    Dim endColumn As Integer

    startColumn = 6
    endColumn = (startColumn + lastcol) - 1
    Range(Columns(startColumn), Columns(endColumn)).Select
    
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet4").Sort.SortFields.Add2 Key:=Range(Cells(1, 6), Cells(1, endColumn)) _
    , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
   
    With ActiveWorkbook.Worksheets("Sheet4").Sort
        .SetRange Range(Cells(1, 6), Cells(lr2, endColumn))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Function Unique(ListRange As Range) As Integer
    Dim CellValue As Variant
    Dim UniqueValues As New Collection

    Application.Volatile
    On Error Resume Next
    For Each CellValue In ListRange
        UniqueValues.Add CellValue, CStr(CellValue) ' add the unique item
    Next
    Unique = UniqueValues.Count
End Function

注：该代码虽不够简洁，但可稳定完成汇总任务。

内容的提问来源于stack exchange，提问作者pradeep