Snasui Excel Forum

Code: Select all

Dim cl As New Collection, cItem As Variant
Dim rAll As Range, rs As Range, rt As Range, rtAll As Range
Dim s As String, strc As Variant
Dim iCount As Integer, j As Integer, k As Integer

With Sheets("Database")
    Set rAll = .Range("a2", .Range("a" & .Rows.Count).End(xlUp))
End With
On Error Resume Next
For Each rs In rAll
    s = rs.Value & "_" & rs.Offset(0, 1).Value & "_" & rs.Offset(0, 3).Value
    cl.Add s, s
Next rs
On Error GoTo 0
With Sheets("Summary")
    .Range("a2").Resize(100, 13).ClearContents
    For Each cItem In cl
       Set rt = .Range("c" & .Rows.Count).End(xlUp).Offset(1, 0)
       strc = Split(cItem, "_")
       If rt.Offset(0, -2).End(xlUp).Value <> strc(0) And rt.Offset(0, -1).End(xlUp).Value <> strc(1) Then
            rt.Offset(0, -2).Value = strc(0)
            rt.Offset(0, -1).Value = strc(1)
       End If
       iCount = Application.CountIfs(rAll, strc(0), rAll.Offset(0, 1), strc(1), rAll.Offset(0, 3), strc(2))
       rt.Resize(iCount \ 10 + 1).Value = strc(2)
       j = 0
       For Each rs In rAll
            If cItem = rs.Value & "_" & rs.Offset(0, 1).Value & "_" & rs.Offset(0, 3).Value Then
                j = j + 1
                If j > 1 And (j - 1) Mod 10 + 1 = 1 Then
                    Set rt = rt.Offset(1, 0)
                End If
                rt.Offset(0, (j - 1) Mod 10 + 1).Value = rs.Offset(0, 2).Value
            End If
            If j = iCount Then Exit For
       Next rs
    Next cItem
    Set rtAll = .Range("c2", .Range("c" & .Rows.Count).End(xlUp))
    For k = rtAll.Count To 2 Step -1
        rtAll(k).Offset(0, -2).Resize(1, 13).Insert
    Next k
    .Range("c2", .Range("c" & .Rows.Count).End(xlUp).Offset(1, 0)) _
        .SpecialCells(xlCellTypeBlanks).Value = "Check"
End With