Oscar Sun

                  Option Explicit

Sub test()
Dim rng As Range, c, b, st, i As Long, j As Long, rw, flg As Boolean, r
Dim buyer() As String
Dim buyerCnt() As Long
Set rng = ActiveSheet.UsedRange
rw = 1
ReDim Preserve buyer(0)
ReDim Preserve buyerCnt(0)
For Each c In rng.Columns(5).Cells
    If c <= VBA.Replace(VBA.Date, "/", "") Then
        buyer(0) = rng.Cells(c.Row, 1)
        Exit For
    End If
Next c
buyerCnt(0) = 1
For Each c In rng.Columns(1).Cells
    If rw > 2 Then
'    If c = "同事" Then Stop
        For Each b In buyer
            If VBA.StrComp(c, b) = 0 Then
                buyerCnt(j) = buyerCnt(j) + 1
                flg = True
                Exit For
            End If
            j = j + 1
        Next b
        j = 0
        If Not flg Then
            i = i + 1
            ReDim Preserve buyer(i)
            ReDim Preserve buyerCnt(i)
            buyer(i) = c.Value
            buyerCnt(i) = 1
        End If
        flg = False
    End If
    rw = rw + 1
Next c
'取得購買者購買量（以上）
'陣列排序：
rw = UBound(buyerCnt)
reOrder:
For i = 0 To rw - 1
    If buyerCnt(i) < buyerCnt(i + 1) Then
        c = buyerCnt(i)
        b = buyerCnt(i + 1)
        buyerCnt(i) = b
        buyerCnt(i + 1) = c
        c = buyer(i)
        b = buyer(i + 1)
        buyer(i) = b
        buyer(i + 1) = c
    End If
Next i
For i = 0 To rw - 1
        If buyerCnt(i) < buyerCnt(i + 1) Then
            GoTo reOrder
        End If
Next i
'找出前3名：
j = 0
For i = 0 To rw - 1
    If buyerCnt(i) > buyerCnt(i + 1) Then j = j + 1
    If j = 3 Then
        c = i '記下要列出幾個購買者
        Exit For
    End If
Next i
flg = False
For i = 0 To c
rep:
    For Each b In rng.Columns(1).Cells
        If b.Value = buyer(i) Then '列出前3名的購買者明細
            If rng.Rows(b.Row).Cells(5) <= VBA.Replace(VBA.Date, "/", "") Then
                For Each st In ActiveWorkbook.Sheets '若沒有工作表則新增
                    If st.Name = buyer(i) Then
                        flg = True
                        Exit For
                    End If
                Next
                If flg = False Then
                    Set st = ActiveWorkbook.Sheets.Add
                    st.Name = buyer(i)
                    For j = 1 To rng.Rows(b.Row).Cells.Count
                        st.Rows(1).Cells(j) = rng.Rows(1).Cells(j)
                    Next
                Else
                    flg = False
                End If
                If r = 0 Then
                    r = st.UsedRange.Rows.Count + 1
                Else
                    r = r + 1
                End If
                Set rw = st.Rows(r)
                For j = 1 To rng.Rows(b.Row).Cells.Count
                    rw.Cells(j) = rng.Rows(b.Row).Cells(j)
                Next
                rng.Rows(b.Row).Delete
                GoTo rep
            End If
        End If
    Next b
    r = 0
Next i
End Sub