VBA在列中查找一系列相同的值并计算平均值

Question

我想在 A列中找到一系列相同的值，然后计算平均值，任何人都可以帮助我吗？在代码下面：

https://i.stack.imgur.com/bU1hW.png

Sub test()
    Dim sht As Worksheet
    Dim LastRow As Long
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

For i = 1 To LastRow
Columns("A:A").Select
    Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

If cell Is Nothing Then
    'do it something

Else
    'do it another thing
End If

End Sub

谢谢！

Answer 1

解决方案1 ​​

试试这个

Sub test()
    Dim sht As Worksheet
    Dim inputLR As Long, outputLR As Long
    Dim cel As Range, aRng As Range, bRng As Range

    Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet

    With sht
        inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row in column A
        outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row   'last row in column D
        Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
        Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B

        For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
            cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
        Next cel
    End With
End Sub

参见图片以供参考。

解决方案2

另一种更简单的方法是使用公式。在Cell E2

中输入以下公式

=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)

根据需要拖动/复制。根据您的数据更改范围。

有关AVERAGEIF的详细信息，请参阅this。

编辑：1

Sub test()
    Dim sht As Worksheet
    Dim inputLR As Long, outputLR As Long
    Dim cel As Range, aRng As Range, bRng As Range
    Dim dict As Object, c As Variant, i As Long

    Set dict = CreateObject("Scripting.Dictionary")
    Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet

    With sht
        inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row    'last row in column A
        Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
        Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B

        c = aRng
        For i = 1 To UBound(c, 1)
            dict(c(i, 1)) = 1
        Next i
        .Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys)  'display uniques from column A
        outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row   'last row in column D

        For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
            cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
        Next cel
    End With
End Sub

编辑：2 要获取Min，而不是

For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
    cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel

使用

For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4))   'loop through each cell in Column D
    cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value

Answer 2

使用WorksheetFunction.AverageIf功能，请参阅以下代码：

Sub test()

Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double

Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    Set Rng = .Range("A1:A" & LastRow)
    ' average of values in column B of all cells in column A = 1
    Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))

    ' average of values in column B of all cells in column A = 2
    Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With

End Sub

Answer 3

这是使用变量数组方法。试试这个。

Sub test()
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim vDB, vR(), rngDB, vResult()
    Dim r As Integer, n As Long, j As Long, i As Integer

    Set sht = ThisWorkbook.Worksheets("Sheet1")
    With sht
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        rngDB = .Range("a1", "b" & LastRow)
        vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))

        r = UBound(vDB, 1)
        ReDim vResult(1 To r)
        For i = 1 To r
            n = 0
            For j = 1 To LastRow
                If vDB(i, 1) = rngDB(j, 1) Then
                    n = n + 1
                    ReDim Preserve vR(1 To n)
                    vR(n) = rngDB(j, 2)
                End If
            Next j
            vResult(i) = WorksheetFunction.Average(vR)
        Next i
        .Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
    End With
End Sub

Answer 4

使用.Find功能

1. 查找A列中的值（不包括重复项）
2. 使用Find功能
上的唯一值
3. 找到值时，将B列和计数器上的值相加

4. 将和值除以计数器以获得平均值

   Dim ws As Worksheet
   Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
   
   Set ws = ThisWorkbook.Sheets(1)
   lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
   
   For i = 2 To lastrow
   
       Set c = ws.Cells(i, 1)
       Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
   
       x = Application.WorksheetFunction.CountIf(rngloop, c)
   
       If x = 1 Then
       'Debug.Print c 'Values in column A without duplicates
           'Work with the values found
           With rng
           Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
               If Not cellFound Is Nothing Then
                   FirstAddress = cellFound.Address
                   Do
                       SumValues = ws.Cells(cellFound.Row, 2) + SumValues
                       k = k + 1
                       Set cellFound = .FindNext(cellFound)
                   Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
                   AverageValues = SumValues / k
                   Debug.Print "Value: " & c & " Average: " & AverageValues
                End If
           End With
       End If
       k = 0
       SumValues = 0
   Next i
   

请注意，.Find的使用速度比CreateObject("Scripting.Dictionary")慢，因此对于大型电子表格，@ Mrig的代码已经过优化

Answer 5

请尝试以下代码：

Sub test()

    Dim sht As Worksheet
    Dim LastRow As Long
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

    For i = 1 To LastRow        
        If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
            'if found more than one value
            'do it another thing
            sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
                            sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
        Else
           'do it another thing
        End If
    Next i

End Sub

希望得到这个帮助。