ตัวอย่าง Code สำหรับทำงานที่ชีต Summary ตามด้านล่างครับ
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
ส่วนกรณีคัดลอกไปชีตอื่น ๆ ให้เขียนมาเองก่อน ติดตรงไหนค่อยถามกันต่อ
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
