Excel Sütunda ki Bilgileri Satırlara Yazdırmak

[actil]

Merhaba,

Excel de VBA ile sütunlarda bulunan verileri satırlara yazdırmak istiyorum.
Bu konuda yardımcı olabilecek var mı? Yapmak istediğim tam olarak şu;

Elimde aşağıda ki gibi bir tablo var, tablnun sütün sayısı 100'ü geçmiyor, ancak satır sayısı 5000 ler civarında.

A1 - B1 - C1 - D1 - E1 .... (max 100)
AB - AA - CA
CA - BA - DA - KA
DE - GB
CS - AD - DR - RF - GH
..
..

Yukarıda ki gibi bir data var, A1 hücresinde yer alan verilerin, B1, C1 ... hücrelerinde karşılıkları var, ben bunları şu hale dönüştürmek istiyorum.

A1 - B1
AB - AA
AB - CA
CA - BA
CA - DA
CA - KA
DE - GB
CS - AD
CS - DR
CS - RF
CS - GH

Teşekkürler,

 

[askm]

Örnek dosya ekleyebilir misiniz.

 

[actil]

Dosya ekleme yetkim olmadığı için ekleyemedim
o yüzden uzun uzun anlatmaya çalıştım...

 

[Ömer]

Merhaba,

Sayfa1 deki verileri istediğiniz düzene göre Sayfa2 de listeler.

Sub Duzenle()

    Dim S2 As Worksheet, i As Long, sat As Long, sut As Integer
    
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    Sheets("Sayfa1").Select
    S2.Rows("2:" & Rows.Count).ClearContents
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    
        sut = Cells(i, Columns.Count).End(xlToLeft).Column
        sat = S2.Cells(Rows.Count, "A").End(xlUp).Row + 1
        If sut = 1 Then
            S2.Cells(sat, "A") = Cells(i, "A")
        Else
            Cells(i, "A").Copy S2.Cells(sat, "A").Resize(sut - 1, 1)
        End If
        
        If sut > 1 Then
            Cells(i, "B").Resize(1, sut - 1).Copy
            S2.Cells(sat, "B").Resize(sut - 1, 1).PasteSpecial _
                Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True
        End If
  
    Next i
    Application.CutCopyMode = False
    
    S2.Select
    Application.ScreenUpdating = True
    
End Sub

.

 

[YUSUF44]

Alternatif:

Sub dağıt()
Set s1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
sonsatır = s1.Cells(Rows.Count, "A").End(3).Row
For i = 1 To sonsatır
    sonsütun = s1.Cells(i, Columns.Count).End(xlToLeft).Column
    If sonsütun > 1 Then
        For j = 2 To sonsütun
            yeni = S2.Cells(Rows.Count, "A").End(3).Row + 1
            S2.Cells(yeni, "A") = s1.Cells(i, "A")
            S2.Cells(yeni, "B") = s1.Cells(i, j)
        Next
    End If
Next
            
    
End Sub

 

[actil]

hocam müthiş
Teşekkür ederim.