GBKEE

¦^´_ 1# ¤Ñ´P
    Sub Ex()
    Dim A, Text$, i%
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
        Text = Join(Application.Transpose(Application.Transpose(A.Resize(, 5).Value)), "-")
        If d.EXISTS(Text) Then
            d(Text) = d(Text) + 1
        Else
            d(Text) = 1
        End If
    Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        i = 2
        For Each A In d.keys
            .Cells(i, "A").Resize(, 5) = Split(A, "-")
            .Cells(i, "F") = d(A)
            i = i + 1
        Next
    End With
    Application.ScreenUpdating = True
End Sub

GBKEE

¦^´_ 4# ¤Ñ´P
Sub Ex()
    Dim D As Object, A As Range, Ar1(), Ar2()
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
            Ar1 = Application.Transpose(Application.Transpose(A.Resize(, 5).Value))
            Ar2 = Application.Transpose(Application.Transpose(A.Resize(, 6).Value))
            If D.EXISTS(Join(Ar1, "")) Then
                Ar2(6) = D(Join(Ar1, ""))(6) + 1
                D(Join(Ar1, "")) = Ar2
            Else
                Ar2(6) = 1
                D(Join(Ar1, "")) = Ar2
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        .[A2].Resize(D.Count, 6) = Application.Transpose(Application.Transpose(D.items))
    End With
    Application.ScreenUpdating = True
End Sub

GBKEE

¦^´_ 5# luhpro
Vba ªº¸Ñªk¦³³\¦h ºÝ¬Ý­Ó¤H³ß¦n
Sub Ex()
    Dim Ar(), j%, Text$, R
    Sheets("Result").Range("A2:G65536").Clear
    With Sheets("Date")
        ReDim Ar(0)
        Ar(0) = Join(Application.Transpose(Application.Transpose(.[A1].Resize(1, 5))), "-")
        For j = 2 To .Range("B65536").End(xlUp).Row
        ' ®M¥Î Join ¤èªk·f°t Cells
            Text = Join(Application.Transpose(Application.Transpose(.Cells(j, "B").Resize(1, 5))), "-")
            R = Application.Match(Text, Ar, 0)
            With Sheets("Result")
                If Not IsNumeric(R) Then
                    ReDim Preserve Ar(UBound(Ar) + 1)
                    Ar(UBound(Ar)) = Text
                    .Cells(UBound(Ar) + 1, "A").Resize(1, 5) = Split(Text, "-")
                    .Cells(UBound(Ar) + 1, "F") = 1
                Else
                    .Cells(R, "F") = .Cells(R, "F") + 1
                End If
            End With
        Next j
    End With
End Sub