有不同的方法可以做到这一点：您可以使用Excel的“小计”功能，选择“平均”作为小计的功能：

然而，这里你有一个缺点，你在同一个页面上的结果，这些结果看起来像这样（点击左边距的2后）：

为了将结果显示在另一个页面上，您可以使用=Subtotals()函数，但也可以使用Bugdrown已经建议的pivot表，它应该是这样的：

获取匹配行的列平均值

VBA

Sub PopulateAverages()
    
    ' Define constants.
    
    Const SRC_SHEET As String = "Sheet1"
    Const DST_SHEET As String = "Sheet2"
    Const DST_FIRST_CELL As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the source values to an array.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    
    Dim srg As Range, srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1
        If srCount = 0 Then Exit Sub ' no data rows
        cCount = .Columns.Count
        If cCount < 2 Then Exit Sub ' no value columns
        Set srg = .Resize(srCount).Offset(1)
    End With
    
    Dim sData(): sData = srg.Value
    
    ' Write the unique values from the first column to the 'keys'
    ' of a dictionary and each row index to the collection held
    ' by the associated 'items'.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sKey, sr As Long
    
    For sr = 1 To srCount
        sKey = sData(sr, 1)
        If Not IsError(sKey) Then
            If Len(CStr(sKey)) > 0 Then
                If Not dict.Exists(sKey) Then
                    Set dict(sKey) = New Collection
                End If
                dict(sKey).Add sr
            End If
        End If
    Next sr
    
    If dict.Count = 0 Then Exit Sub ' only blanks and/or error values
    
    ' Write the averages to another array.
    
    Dim dData(): ReDim dData(1 To dict.Count, 1 To cCount)
    
    Dim sItem, sValue, dr As Long, c As Long, tCount As Long, Total As Double
    
    For Each sKey In dict.Keys
        dr = dr + 1
        dData(dr, 1) = sKey
        tCount = dict(sKey).Count
        For c = 2 To cCount
            For Each sItem In dict(sKey)
                sValue = sData(sItem, c)
                If VarType(sValue) = vbDouble Then
                    Total = Total + sValue
                End If
            Next sItem
            dData(dr, c) = Total / tCount ' maybe do some rounding here
            Total = 0 ' reset for the next iteration (column)
        Next c
    Next sKey

    ' Write the values from the array to the destination range.

    ' Reference the destination range.
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    ' Write the result.
    drg.Value = dData
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
    
    ' Inform.
    
    MsgBox "Averages populated.", vbInformation

End Sub

Excel公式（Microsoft 365）

=LET(data,Sheet1!A2:D6,
    ud,TAKE(data,,1),vd,DROP(data,,1),
    u,TOCOL(UNIQUE(ud),3),
    rd,REDUCE("",u,LAMBDA(rr,r,LET(
            f,FILTER(vd,ud=r),
            bc,BYCOL(f,LAMBDA(c,
                AVERAGE(c))),
        VSTACK(rr,bc)))),
HSTACK(u,DROP(rd,1)))

尝试
假设A-B-C-D列中的Spe-Vol-C-Qte

Sub CalculateAverages()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim cell As Range
    Dim value As Variant
    Dim sumVol As Double, sumC As Double, sumQTE As Double
    Dim countVol As Long, countC As Long, countQTE As Long
    Dim currentRow As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1") ' Replace "Sheet1" with your sheet name
    Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' Replace "Sheet2" with your sheet name
    

    Set dict = CreateObject("Scripting.Dictionary")
    
    lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    
        ' Add unique values to the dictionary
    For Each cell In ws1.Range("A2:A" & lastRow)
        If Not dict.Exists(CStr(cell)) Then
            dict(CStr(cell)) = True
        End If
    Next cell
    
    ' Set initial row in Sheet2
    currentRow = 2
    
    ' Loop through each unique value in the dictionary
    For Each value In dict.Keys
        
        sumVol = 0
        sumC = 0
        sumQTE = 0
        countVol = 0
        countC = 0
        countQTE = 0

        For Each cell In ws1.Range("A2:A" & lastRow)
            If CStr(cell.value) = value Then
                sumVol = sumVol + cell.Offset(0, 1).value
                sumC = sumC + cell.Offset(0, 2).value
                sumQTE = sumQTE + cell.Offset(0, 3).value
                countVol = countVol + 1
                countC = countC + 1
                countQTE = countQTE + 1
            End If
        Next cell
        
        ' Write results to Sheet2
        ws2.Cells(currentRow, "A").value = value
        ws2.Cells(currentRow, "B").value = sumVol / countVol
        ws2.Cells(currentRow, "C").value = sumC / countC
        ws2.Cells(currentRow, "D").value = sumQTE / countQTE
        
        ' Move to the next row in Sheet2
        currentRow = currentRow + 1
    Next value
End Sub