|
Sub aa() Dim rng1 As Range, rng2 As Range Dim d As Object For i = 1 To Range("a65536").End(xlUp).Row Set d = CreateObject("scripting.dictionary") Set rng = Range(Cells(i, 1), Cells(i, 11)) Set rng2 = Range(Cells(i, 13), Cells(i, 31)) For Each cel2 In rng2 If Not d.exists(cel2.Value) Then d.Add cel2.Value, 1 Else d(cel2.Value) = d(cel2.Value) + 1 Next For Each cel In rng If d.exists(cel.Value) Then d(cel.Value) = d(cel.Value) + 1 Next ReDim w(1 To d.Count) a = d.keys: b = d.items s = 0 For j = 0 To d.Count - 1 If b(j) > 1 Then s = s + 1: Cells(i, s + 32) = a(j) Next j Set d = Nothing Next i End Sub |
|