Snasui Excel Forum

Code: Select all

Dim d As Object, a(999, 2) As Variant, i As Integer
Dim rall As Range, r1 As Range, r2 As Range, j As Integer
Set d = CreateObject("Scripting.Dictionary")
With Sheets("ฐานข้อมูล")
    Set rall = .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
    For Each r In rall
        If Not d.exists(r.Value) Then
            d.Add Key:=r.Value, Item:=r.Value
            a(i, 0) = r.Value
            j = 1
            For Each r1 In rall
                If r1.Value = a(i, 0) Then
                    a(i, 1) = j
                    a(i, 2) = a(i, 2) + r1.Offset(0, 1).Value
                    j = j + 1
                End If
            Next r1
            i = i + 1
        End If
    Next r
End With
With Sheets("ทดสอบ")
    .Range("a5").Resize(.UsedRange.Rows.Count, 3).ClearContents
    .Range("a5").Resize(i + 1, 3).Value = a
    With .Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("a5").Resize(i), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("a5").Resize(i, 3)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With