.::Bir'den Fazla Sütundaki Verileri Boşluksuz-Sıralı Aktarma::.

[Ömer BARAN]

Bir'den fazla sütundaki verileri, alt alta boşluksuz olarak ve kendi satırında D:F sütun aralığındaki verileri tekrarlayarak aktarmak istiyorum.

Elle yaptığım sıralama ekli belgede yapılmıştır.
İlgileneceklere teşekkürler.

 

[feridici_genc]

Selamun aleykum,
vereceğim cevap büyük ihtimal ile isteğinizi tam karşılamıyor ama, sadece fikir uyandırabileceğinden dolayı paylaşmak istedim. makro kaydederek yaptım. daha fazlası için gerekli bilgi donanımı bende yok

Sub siralama()
'
' siralama Makro
'

'
    Range("Q2:Q5").Select
    Selection.Copy
    Range("U2").Select
    ActiveSheet.Paste
    Range("R2:R5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U6").Select
    ActiveSheet.Paste
    Range("S2:S5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U10").Select
    ActiveSheet.Paste
    Range("T2:T5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U14").Select
    ActiveSheet.Paste
    Range("Q6:Q12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U18").Select
    ActiveSheet.Paste
    Range("R6:R12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U25").Select
    ActiveSheet.Paste
    Range("S6:S12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U32").Select
    ActiveSheet.Paste
    Range("T6:T12").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=18
    Range("U39").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-18
    Range("Q13:Q18").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=21
    Range("U46").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-15
    Range("R13:R18").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=27
    Range("U52").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-27
    Range("S13:S18").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=21
    Range("U58").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-18
    Range("T13:T18").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=33
    Range("U64").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-36
    Range("Q19:Q22").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=39
    Range("U70").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-36
    Range("R19:R22").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=39
    Range("U74").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-48
    Range("S19:S22").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=60
    Range("U78").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-57
    Range("T19:T22").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=57
    Range("U82").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=-102
    Range("T1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("U1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "SIRALAMA"
    Columns("U:U").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp
    Range("X6").Select
End Sub

 

[veyselemre]

Sub vEmre()
    Sheets("Sayfa1").Select
    With CreateObject("Scripting.Dictionary")
        Dim w(1 To 1), y()
        For Each huc In Range("N2:N" & Rows.Count).SpecialCells(xlCellTypeConstants, 23)
            key = Join(Application.Index(Cells(huc.Row, "D").Resize(1, 3).Value, 0, 0), "|")
            veri = Join(Application.Index(Cells(huc.Row, "N").Resize(1, 4).Value, 0, 0), "|")

            If Not .exists(key) Then
                w(1) = veri
                .Item(key) = w
            Else
                y = .Item(key)
                ReDim Preserve y(1 To UBound(y) + 1)
                y(UBound(y)) = veri
                .Item(key) = y
            End If
        Next huc

        Dim z(1 To 4)

        For i = 18 To 20
            For Each huc In Range(Cells(2, i), Cells(Rows.Count, i)).SpecialCells(xlCellTypeConstants, 23)
                key = Join(Application.Index(Cells(huc.Row, "D").Resize(1, 3).Value, 0, 0), "|")
                z(4) = huc.Value
                veri = Join(z, "|")
                If Not .exists(key) Then
                    w(1) = veri
                    .Item(key) = w
                Else
                    y = .Item(key)
                    ReDim Preserve y(1 To UBound(y) + 1)
                    y(UBound(y)) = veri
                    .Item(key) = y
                End If
            Next huc

        Next i
        key = .keys
        Item = .items

    End With
    Sheets.Add
    sat = 2
    For i = 0 To UBound(Item)
        v = Item(i)
        For ii = LBound(v) To UBound(v)
            Cells(sat, "G").Resize(1, 4).Value = Split(v(ii), "|")
            Cells(sat, "C").Resize(1, 3).Value = Split(key(i), "|")
            sat = sat + 1
        Next ii
    Next

  Erase v, w, y, key, z, Item
End Sub

 

[Ömer BARAN]

Çok teşekkürler Veysel Bey,
İhtiyaç tam olarak karşılanmış durumda.
Acilen Scripting.Dictionary olayını öğrenmem gerekiyor anlaşılan.
Sağ olunuz.