Birimlere göre ayırmak

[ocak26]

Merhaba Arkadaşlar Listeye bakıp yardımcı olursanız sevinirim
Şimdiden çok teşekkür ederim.

 

[sakman26]

selam,
dosyanız ektedir.
kolay gelsin.

 

[ocak26]

LİSTE

Merhabalar
az önce gönderdiğim listedeki yardımınızdan dolayı teşekkür ederim. Ekli listede açıkladığım şekilde yaparsanız sevinirim
teşekkürler

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub birim59()
Dim z As Object, liste(), myarr(), n As Long
Dim sh As Worksheet, i As Long
Sheets("Sayfa 1").Select
Set sh = Sheets("Sayfa2")
sh.Range("A5:G" & Rows.Count).ClearContents
liste = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 7, 1 To UBound(liste))
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        n = n + 1
        z.Add liste(i, 1), n
        myarr(1, n) = liste(i, 1)
    End If
    If liste(i, 2) = "PEM" Then myarr(2, n) = "X"
    If liste(i, 2) = "CEM" Then myarr(3, n) = "X"
    If liste(i, 2) = "İD" Then myarr(4, n) = "X"
    If liste(i, 2) = "İDM" Then myarr(5, n) = "X"
    If liste(i, 2) = "ÇEM" Then myarr(6, n) = "X"
    If liste(i, 2) = "GEM" Then myarr(7, n) = "X"
Next i
Erase liste
If z.Count > 0 Then
    sh.Range("A5").Resize(z.Count, 7) = Application.Transpose(myarr)
End If
sh.Select
Set z = Nothing
Set sh = Nothing
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub