Tek sütun veriyi çoklu sütun ayırma

[28sefa16]

Herkese Merhabalar,

300 satırlık tek sütun veri var. Bu verileri 11 li sütun haline her satırda bir boşluk bırakarak alt alta ayırmak istiyorum.

A sütununu kullanıyor olalım; veri A1 den A300(bu değişkenlik gösteriyor farklı dosyada farklı olacak) e kadar.

A1-A11
boşluk
A12-A22
boşuk
A23-A33
..... (Sütun sonuna kadar)

Teşekkürler

 

[Mdemir63]

Selamlar
Sitemize hoş geldiniz.
Yapmak istediğinizi gerçek bilgilerinizi içermeyen örnek bir dosya da manuel olarak hazırlayıp harici dosya yükleme sitelerinden birine ekleyerek burada Link paylaşırsanız daha çabuk cevaplar alırsınız.

iyi çalışmalar

 

[28sefa16]

bilgilendirme için çok teşekkür ederim. Ancak bir formül yada yöntem öğrenmek istiyorum. Sürekli kullanmam gerekiyor. Sadece içerik kopyalansa yeterli çizgiler vs. önemli değil biçimlendirme ile değiştiririz.

kaynak dosya: https://dosya.co/iqq0a3t0te4m/SmartWiring.xls.html
Yapmak istediğim: https://dosya.co/x3ro01zpx2x1/hedef.xls.html

 

[veyselemre]

Sub test()
    Dim lst, dizi, sat, i&, ii%, setSay%, idx&
    With Sheets("SmartWiring")
        .Range("B:L").ClearContents
        lst = .Range("A1:A" & .Cells(Rows.Count, 1).End(3).Row).Value
        sat = 1
        setSay = WorksheetFunction.RoundUp(UBound(lst) / 11, 0)
        ReDim dizi(1 To setSay * 2, 1 To 11)
        For i = 1 To setSay * 11 Step 11
            For ii = 1 To 11
                idx = i + ii - 1
                If idx <= UBound(lst) Then
                    dizi(sat, ii) = lst(idx, 1)
                End If
            Next ii
            sat = sat + 2
        Next i
        .Range("B1").Resize(sat - 2, 11).Value = dizi
    End With
End Sub

 

[muratboz06]

Deneyiniz.

Sub OnbirliListeOlustur()
Application.ScreenUpdating = False
Dim rng As Range
Dim I As Long
    
    Set rng = Range("A1")
    While rng.Value <> ""
        I = I + 1
        rng.Resize(11).Copy
        Range("B" & I).PasteSpecial Transpose:=True
        Set rng = rng.Offset(11)
        
    Wend
    rng.EntireColumn.Delete
sonSatir = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
ActiveSheet.Range("A1").Select
For I = 1 To sonSatir - 1
    ActiveCell.Offset(1, 0).EntireRow.Insert
    ActiveCell.Offset(2, 0).Select
Next I
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı..."
End Su

 

[28sefa16]

Hocam çok teşekkür ederim çalıştırdık. Umarım her şey gönlünüzce olur.

 

[Necdet]

Alternatif olsun,

Sütun adedini ve satır atlama sayısını siz kendinize göre düzenleyin.

Public Sub YatayGrup()

Dim ar1 As Variant, _
    ar2 As Variant, _
    i   As Long, _
    j   As Long, _
    sAd As Integer, _
    rAd As Integer, _
    k   As Integer

sAd = 11 'Sütun Adedi
rAd = 2 'Satır Atlama Adedi

ar1 = Range("A1").CurrentRegion.Value

i = Int(UBound(ar1, 1) / sAd) * rAd + 1

ReDim ar2(1 To i, 1 To sAd)

k = 1
j = 1

For i = 1 To UBound(ar1, 1)
    ar2(j, k) = ar1(i, 1)
    k = k + 1
    If k > sAd Then
        k = 1
        j = j + rAd
    End If
Next i

With Range("C1")
    .CurrentRegion.ClearContents
    .Resize(UBound(ar2, 1), UBound(ar2, 2)) = ar2
End With

End Sub