satırları sütunlara dönüştürme, ( biraz daha karışık :) )

[nickimikedi7]

Merhaba arkadaşlar;
Şöyle bir sorunum var;
elimdeki excelde yan yana iki sütunda veriler var örneğin;

SIBAS2 SLPGO1
SIBAS2 SLPGO3
OZAYP3 NEZIR2
OZAYP3 NEZIR4
OZAYP3 NUSYS1
SCALI1 SIBAS2
SCALI1 XYDCX1
SCALI1 GORML1

ve ben bunu bir makro yada formul yardımıyla otomatik olarak
SIBAS2 SLPGO1 SLPGO3
OZAYP3 NEZIR4 NUSYS1 SIBAS2
SICAL1 HABUR1 HABUR3 GORML1

İlk sütundan ilk benzer veriyi alıp yanına ikinci sütundaki değişkenleri yazmasını istiyorum, yani SIBAS2 yi alsın yan tarafına slpgo1 ve slpgo3 yazsın sonra bir alt satıra geçeerek ozayp3 yazsın ve yanına nezir2 nezir4 nusys1 yazsın istiyorum. yardımı dokunacak herkse şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Option Explicit
 
Sub BENZERSİZ_LİSTELE()
    Dim S1 As Worksheet, S2 As Worksheet, Satır As Long, Sütun As Byte
    Dim X As Long, BUL As Range, ADRES As String
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Cells.Clear
    Satır = 1
    Sütun = 2
    
    For X = 1 To S1.Cells(Rows.Count, 1).End(3).Row
        If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(X, 1)) = 0 Then
            S2.Cells(Satır, 1) = S1.Cells(X, 1)
            Set BUL = S1.Range("A:A").Find(S1.Cells(X, 1), , , xlWhole, xlRows)
            If Not BUL Is Nothing Then
                ADRES = BUL.Address
                Do
                    S2.Cells(Satır, Sütun) = BUL.Offset(0, 1)
                    Sütun = Sütun + 1
                
                Set BUL = S1.Range("A:A").FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
            
            Sütun = 2
            Satır = Satır + 1
        End If
    Next
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[nickimikedi7]

Çok teşekkür ederim ) çalışıyor, elinize sağlık