Soru Sütundaki bilgilerin satırlara yayılması

[basaksehirli]

İyi günler arkadaşlar.

4 sütundaki bilgilerin sıraları olarak yan sütunlara taşınmasını yapamadım. Örneğin;



A B C D | E F G H
1 2 3 4 | 5 6 7 8
5 6 7 8 |

Tam anlatamamış olabilirim. Örnek dosya ekledim, yardımcı olursanız sevinirim.

 

[Cengiz Demir]

Sizin örneğiniz biraz karışık olmuş. Sanırım kırmızı grupda daha çok veri olacak.
Siz o grubu hem hedef hemde kaynak gibi kullanmışsınız. Bu da işlem yaparken gereksiz yere ekstra kodlamalar yapmayı gerektirebilir.

Kırmızı grubu kaynak olarak bırakıp. Hedep grup sayısını 4 yapıp. Kırmızı gruptakileri o dört gruba işletecek bir çalışma yapmak gerekir.
Üstadlar sanırım bu konuda yardımcı alabilirler.

 

[basaksehirli]

Cevap için teşekkürler. Dediğim gibi olsa daha iyi olurdu çünkü bu verileri mektup posta birleştirmeyle worde aktarıyorum. Ama olmazsa dediğiniz gibi de olabilir tabi.

 

[basaksehirli]

Farklı çözüm önerilerine, yöntemlerine, bilgilerine açığım. Olmazsa olmaz bir konu değil ama olursa bugün için benim için daha iyi olabilir.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Yana_Aktar()
    Dim X As Long, Sutun As Integer, Y As Long
    
    Range("E2:XFD" & Rows.Count).Clear
    
    For X = 3 To Cells(Rows.Count, 1).End(3).Row Step 3
        Sutun = 5
        For Y = X To X + 2
            If Cells(Y, "A") <> "" Then
                Cells(Rows.Count, Sutun).End(3)(2, 1).Resize(, 4).Value = Cells(Y, "A").Resize(, 4).Value
                Cells(Y, "A").Resize(, 4).ClearContents
                Sutun = Sutun + 4
            End If
        Next
        X = X + 1
    Next

    Range("A2:D" & Rows.Count).SpecialCells(xlCellTypeBlanks).Delete xlUp

    Columns.AutoFit

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[basaksehirli]

Korhan hocam çok teşekkür ederim iyi geceler.

 

[basaksehirli]

Korhan hocam, yukarıda Cengiz arkadaşımızın söylediği örneklemeyi yorucu ve uzun değilse yapar mısınız ? Yoksa önemli değil.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Yana_Aktar()
    Dim X As Long, Sutun As Integer, Y As Long
    
    Range("E2:XFD" & Rows.Count).Clear
    
    For X = 2 To Cells(Rows.Count, 1).End(3).Row Step 4
        Sutun = 5
        For Y = X To X + 3
            If Cells(Y, "A") <> "" Then
                Cells(Rows.Count, Sutun).End(3)(2, 1).Resize(, 4).Value = Cells(Y, "A").Resize(, 4).Value
                Sutun = Sutun + 4
            End If
        Next
    Next

    Columns.AutoFit

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[basaksehirli]

Hocam çok iyi oldu. Harikasın