DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub OzetListe()
Dim d, s, a1, a2, deg, i As Long
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Sheets("Sayfa1").Select
Range("A2:B" & Rows.Count).ClearContents
With Sheets("Sayfa2")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
deg = .Cells(i, "B")
If Not d.exists(deg) Then
s = Array(1, .Cells(i, "C"))
d.Add deg, s
Else
s = d.Item(deg)
s(1) = s(1) & "-" & .Cells(i, "C")
d.Item(deg) = s
End If
Next i
a1 = d.keys: a2 = d.items
For i = 0 To d.Count - 1
Cells(i + 2, "A") = a1(i)
s = a2(i)
Cells(i + 2, "B") = s(1)
Next i
End With
Set d = Nothing
Application.ScreenUpdating = True
End SubSub OzetListe()
Dim d, s, a1, a2, deg, i As Long
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Sheets("ANASAYFA TL").Select
Range("H32:I" & Rows.Count) = ""
With Sheets("Ana Sayfa")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
If .Cells(i, "B") <> "" And .Cells(i, "F") <> "" Then
deg = .Cells(i, "B")
If Not d.exists(deg) Then
s = Array(1, .Cells(i, "F"))
d.Add deg, s
Else
s = d.Item(deg)
s(1) = s(1) & "-" & .Cells(i, "F")
d.Item(deg) = s
End If
End If
Next i
a1 = d.keys: a2 = d.items
For i = 0 To d.Count - 1
Cells(i + 32, "H") = a1(i)
s = a2(i)
Cells(i + 32, "I") = s(1)
Next i
End With
Set d = Nothing
Application.ScreenUpdating = True
End Sub