Snasui Excel Forum

Code: Select all

Sub test0()
    Dim rall As Range, r As Range, l As Long, k As Long, m As Integer
    Dim d As Object, itm As Object, a As Variant, b As Range
    
    Set d = CreateObject("Scripting.Dictionary")
    
    With Sheets("DATA")
        Set rall = .Range("b2", .Range("b" & .Rows.Count).End(xlUp))
        For Each r In rall
            If Not d.exists(CStr(r.Value)) Then
                d.Add Key:=CStr(r.Value), Item:=CStr(r.Value)
            End If
        Next r
        a = d.items
        For l = 0 To d.Count - 1
            If l = 0 Then
                Set b = Sheets("จดหมาย").Range("d12")
            Else
                Set b = b.Offset(15, 0)
            End If
            m = Application.Match(CLng(a(l)), rall, 0) + 1
            k = Application.CountIf(rall, a(l))
            If k = 1 Then
                b.Value = .Cells(m, "c").Value
                
                Set b = b.Offset(15, 0)
                b.Value = .Cells(m, "c").Value
                b.Offset(1, 0).Value = .Cells(m, "d").Value
            ElseIf k = 2 Then
                b.Value = .Cells(m, "c").Value
                
                Set b = b.Offset(15, 0)
                b.Value = .Cells(m, "c").Value
                b.Offset(1, 0).Value = .Cells(m, "d").Value
                
                Set b = b.Offset(15, 0)
                b.Value = .Cells(m, "c").Value
                b.Offset(1, 0).Value = .Cells(m + 1, "d").Value
            End If
        Next l
    End With
End Sub