35.000 satırlı veriyi çıktı alma

[cl0ud]

Merhaba arkadaşlar elimde 35k tek sütun satırlı veri var bunu yan yana sütunlara nasıl bölebilirim şuan çıktı almak istediğimde 255 sayfa çıktı yapıyor yan yana yaparsam daha az sayfada olacağını düşünüyorum.
örnek tek sütunlu verim.

45200
45231
45261
41275
41640
42005
42370
42736
43101
43466
44958
43831
44197
44986
45017
45047
45078
45108
45139
45170
45087
1000-19
1000-27
1000-28
1001-10
1001-17
1001-20
1001-22
1001-35
1001-36
1002-20
1002-43
1002-44
1002-45
1003-11
1003-12
1003-4
1004-1
1004-3
101-10
101-11
101-157
1013-1
1013-12
1013-14
1013-18
1013-21
1013-25
1013-3
1013-30
1013-32
1013-7
1013-9
1014-12
1014-13
1014-14
1014-18
1014-19
1014-20
1014-23
1014-24
1014-28
1015-1
1015-11
1015-12
1015-13
1015-17
1015-2
1015-23
1015-26
1015-4
1015-6
1015-9
1016-10
1016-11
1016-15
1016-16
1016-18
1016-19
1016-2
1016-20
1016-21
1016-5
1016-7
1016-8
1017-11
1017-12
1017-20
1017-25
1017-29
1017-8
1018-1
1018-11
1018-12
1018-13
1018-14
1018-17
1018-18
1018-22
1018-24

 

[dEdE]

Merhaba,
Aşağıdaki kodu bir modüle yapıştırarak dener misiniz?
Kod; Verilerinizin A1 den başladığını varsayar. B1 Den itibaren her sütun 50 satır olacak şekilde yan yana yazar.

Sub SutunuAyir()
    Set myRng = Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
    Set Sonuc = Range("B1")
 
    sSay = 50
    colSay = myRng.Cells.Count / sSay
 
    ReDim myArr(1 To sSay, 1 To colSay + 1)
 
    For i = 0 To myRng.Cells.Count - 1
        myRow = i Mod sSay
        myCol = Int(i / sSay)
        myArr(myRow + 1, myCol + 1) =  myRng.Cells(i + 1)
    Next
 
    Sonuc.Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
End Sub

.

 

[cl0ud]

Merhaba,
Aşağıdaki kodu bir modüle yapıştırarak dener misiniz?
Kod; Verilerinizin A1 den başladığını varsayar. B1 Den itibaren her sütun 50 satır olacak şekilde yan yana yazar.

Sub SutunuAyir()
    Set myRng = Range("A1:A" & Cells(Rows.Count, "A").End(3).Row)
    Set Sonuc = Range("B1")

    sSay = 50
    colSay = myRng.Cells.Count / sSay

    ReDim myArr(1 To sSay, 1 To colSay + 1)

    For i = 0 To myRng.Cells.Count - 1
        myRow = i Mod sSay
        myCol = Int(i / sSay)
        myArr(myRow + 1, myCol + 1) =  myRng.Cells(i + 1)
    Next

    Sonuc.Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
End Sub

.

Teşekkürler hocam işimi gördü ilginize teşekkür ederim.

 

[dEdE]

Sütunlardaki satır sayısını belirleyebileceğiniz alternatif kod;

Sub SutunuAyir()
    Dim SatSay As Variant
   
    SatSay = Application.InputBox("Sütunlar Kaç Satır olsun? ", "Satır Sayısı Girişi")
    If SatSay = False Or SatSay = "" Then Exit Sub
    ss = Range("A" & Rows.Count).End(xlUp).Row
    SutSay = ss / SatSay
   
For j = 1 To SutSay
    For i = 1 To SatSay
        SatNo = ((j - 1) * SatSay) + i
        If SatNo > ss Then Exit For
        Cells(i, j + 1) = Range("A" & SatNo).Value
    Next i
Next j
End Sub

 

[Muzaffer Ali]

Alternatif.

Sub test()
    Dim Bak As Long
    Dim SatirSayisi As Integer
    SatirSayisi = 50
    For Bak = SatirSayisi + 1 To Cells(Rows.Count, "A").End(xlUp).Row Step SatirSayisi
        Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 1).Resize(SatirSayisi, 1).Value = Cells(Bak, "A").Resize(SatirSayisi + 1, 1).Value
        Cells(Bak, "A").Resize(SatirSayisi, 1).Value = ""
    Next
End Sub

 

[Necdet]

Merhaba,
Bir Seçenek te benden, A sütunundaki verileri belirlenen satır ve sütun kadar hücrelere ayırarak, belirlenen satır kadar sayfa sonu ekler.

Public Sub SatirVeSutunlaraBol()

'A sütunundaki verileri istenilen satır ve sütunlara göre ayırır
'Necdet 20.02.2023

Dim i As Long
Dim j As Long
Dim k As Integer
Dim m As Integer
Dim Kol As Integer
Dim Sat As Integer
Dim arrYaz As Variant
Dim arrOku As Variant
Dim bsSure As Single

bsSure = Timer

ActiveSheet.ResetAllPageBreaks
Sat = 50
Kol = 24

arrOku = Range("A1").CurrentRegion.Value
Range("A1").CurrentRegion.ClearContents

i = Application.WorksheetFunction.RoundUp((UBound(arrOku, 1) / (Sat * Kol)), 0)

ReDim arrYaz(1 To Sat * i, 1 To Kol)
j = 0
k = 1
m = 0

For i = LBound(arrOku, 1) To UBound(arrOku, 1)

    m = m + 1
    If m > Sat Then
        m = 1
        k = k + 1
        If k > Kol Then
            k = 1
            j = j + Sat
        End If
    End If
    
    arrYaz(j + m, k) = arrOku(i, 1)
    
Next i

Range("A1").Resize(UBound(arrYaz, 1), UBound(arrYaz, 2)) = arrYaz

i = Sat + 1
Do Until Cells(i, "A") = ""
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("A" & i)
    i = i + Sat
Loop

MsgBox "Procedure Calisma Suresi : " & Format((Timer - bsSure) / 86400, "hh:mm:ss")

End Sub