tablodaki verileri alt alta yazdırma

[Astalavista58]

Ekteki gibi bir tablo var, sütun sayısı uzadıkça uzuyor, ben örnek olarak koydum. Yapmak istediğim, başlık ve tarihler haricindeki tüm verileri benzersiz bir şekilde alt alta yazdırmak.

DENEME.xlsx dosyasını indir - download

DENEME.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s4.dosya.tc

 

[Astalavista58]

Altın üyeliğim aktif olduğundan kolaylık olması açısında buraya da ekleyim dosyayı

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Benzersiz_Liste()
    Dim S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long
    Dim X As Long, Y As Byte
    Dim Liste As Variant, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Benzersiz Liste").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Son = WorksheetFunction.Max(3, Son)
    
    Veri = S1.Range("B2:" & S1.Cells(Son, S1.Cells(1, S1.Columns.Count).End(1).Column).Address(0, 0)).Value
    
    Dizi.Item("Benzersiz Liste") = False
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = LBound(Veri, 2) To UBound(Veri, 2)
            If Veri(X, Y) <> "" Then Dizi.Item(Veri(X, Y)) = False
        Next
    Next
    
    Liste = Application.Transpose(Dizi.Keys)
    
    Sheets.Add.Name = "Benzersiz Liste"
    Range("A1").Resize(UBound(Liste)) = Liste
    Range("A1").Font.Bold = True
    Range("A:A").Columns.AutoFit
    
    Set S1 = Nothing
    Set Dizi = Nothing
    
    MsgBox "Benzersiz liste oluşturulmuştur." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Astalavista58]

Korhan bey çok çok çok teşekkür ediyorum elinize sağlık, Allah razı olsun sizden. Çok güzel çalışıyor