Sütundaki verileri satıra ekleme

[hayalmeyal]

Merhaba iyi çalışmalar.
A sütunu kodlar, B ve FAT sütunları (4102 sütun) koda ait alt değer olmak üzere 4103 sütun-300 satırlık bir verim var.
Amacım satır sayısını arttırıp, a sütunudaki verileri yinelenen değer olacak şekilde alt alta çoğaltarak, sütun sayısını sadece 2 ye düşürmek.
a başlık-b değer olacak şekilde.
buradaki sorun ise, her sütun dolu değil.
örnek olarak a3 başlığının karşısında c3 dolu, f3 dolu, x3 dolu, fat3 dolu gibi.
olmasını istediğim; fat sütununa kadar her dolu değer kadar a sütunundaki ana başlıkların alt alta çoğalarak değerlerin yanına yazılması

a2=1234 - b2= değer
a3=1234 - b3= değer
a4=1234 - b4= değer
a5=123 - b5= değer
a6=123 - b6= değer

örnek resim ektedir. yardımcı olabilirseniz çok sevinirim.

https://resimyukle.io/r/GCmI649KtI

 

[ÖmerFaruk]

Merhaba.
Başlık yani 1. satırdaki verilerin de gelmesi gerekecek mi?

 

[hayalmeyal]

Merhaba.
Başlık yani 1. satırdaki verilerin de gelmesi gerekecek mi?

1.satira gerek yok hocam

 

[Korhan Ayhan]

Merhaba,

Verilerinizin Sayfa1 de olduğunu varsaydım. Sonuç listesi yeni excel sayfasına aktarılır.

Kodun çalışması için dosyanızda Sayfa1 ve Sayfa2 isimli sayfalar olması gerekiyor.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Variant, X As Long
    Dim Y As Integer, Say As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Cells.Clear
    S2.Range("A1:B1") = Array("Hizmet Kodu", "Değer")
    S2.Range("A1:B1").Font.Bold = True
    
    Veri = S1.Range("A2:FAT" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
    
    ReDim Liste(1 To S1.Rows.Count, 1 To 2)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = 2 To UBound(Veri, 2)
            If Veri(X, Y) <> "" Then
                Say = Say + 1
                Liste(Say, 1) = Veri(X, 1)
                Liste(Say, 2) = Veri(X, Y)
            End If
        Next
    Next
    
    If Say > 0 Then S2.Range("A2").Resize(Say, 2) = Liste
    
    S2.Columns.AutoFit
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hayalmeyal]

@Korhan Ayhan Hocam elinize kolunuza sağlık. Çok teşekkür ederim.