Alt alta olan verileri yanyana belirli adette yazdırma

[time2burn]

Merhabalar a sütununda alt alta 10.000 adet sayılar mevcut, ben bunları sırası bozulmayacak şekilde sıralamak istiyorum.

sıralamam ilk 20 adet sayıyı yan yana hücre sıralayacak, sonra bir alt hücreden devam ederek bu işlem tamamlanacak

bu işlemi nasıl gerçekleştirebilirim ? yardımlarınız için şimdiden teşekkürler.

örnek sıralama biçimi

 

[MusaPEKEL]

Merhabalar a sütununda alt alta 10.000 adet sayılar mevcut, ben bunları sırası bozulmayacak şekilde sıralamak istiyorum.

sıralamam ilk 20 adet sayıyı yan yana hücre sıralayacak, sonra bir alt hücreden devam ederek bu işlem tamamlanacak

bu işlemi nasıl gerçekleştirebilirim ? yardımlarınız için şimdiden teşekkürler.

örnek sıralama biçimi

Sub SayilariSutunlaraSiralayarakYerlestir()
    Dim ws As Worksheet
    Dim colToSort As Integer
    Dim rowCount As Long, colCount As Long
    Dim i As Long, j As Long
    Dim valueArray() As Variant

    ' Çalışmak istediğiniz sayfayı ve sütunu belirtin
    Set ws = Sheets("Sayfa1") ' Sayfa adını güncelleyin
    colToSort = 2 ' Sıralanacak sütunu belirtin (A sütunu)

    ' Sıralama yapılacak sütunun son satırını bulun
    lastRow = ws.Cells(ws.Rows.Count, colToSort).End(xlUp).Row

    ' Sütunu bir diziye alın
    valueArray = ws.Range(ws.Cells(1, colToSort), ws.Cells(lastRow, colToSort)).Value

    ' Diziyi sıralayın
    Call BubbleSort(valueArray)

    ' Sıralı değerleri her satırda 20 adet olacak şekilde yerleştirin
    rowCount = WorksheetFunction.RoundUp(lastRow / 20, 0)
    colCount = 20

    For i = 1 To rowCount
        For j = 1 To colCount
            If (i - 1) * colCount + j <= lastRow Then
                ws.Cells(i, j + 1).Value = valueArray((i - 1) * colCount + j, 1)
            End If
        Next j
    Next i
End Sub

Sub BubbleSort(arr() As Variant)
    Dim i As Long, j As Long
    Dim temp As Variant

    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i, 1) > arr(j, 1) Then
                temp = arr(i, 1)
                arr(i, 1) = arr(j, 1)
                arr(j, 1) = temp
            End If
        Next j
    Next i
End Sub

 

[ÖmerBey]

Merhaba,
Alternatif olarak formülle yapmak isterseniz aşağıdaki formülü hücreye uygulayıp sağa ve aşağı çekerek çoğaltınız.

=İNDİS($A:$A;20*(SATIR(A1)-1)+SÜTUN(A1))

 

[Erkan Akayay]

Sub Gruplama()
Dim kaynak(), hedef()
Dim sayac As Integer, sutun As Integer
sutun = InputBox("Kaç sütun olacak?")
kaynak = Application.Transpose(Range("A1:A" & Range("A1").End(xlDown).Row).Value2)
ReDim hedef(Application.RoundUp((Range("A1").End(xlDown).Row / sutun), 0) - 1, 1 To sutun + 1)
   
    For dizisatir = LBound(hedef, 1) To UBound(hedef, 1)
        For dizisutun = LBound(hedef, 2) To UBound(hedef, 2) - 1
            sayac = sayac + 1
            hedef(dizisatir, dizisutun) = kaynak(sayac)
            If sayac = Range("A1").End(xlDown).Row - 1 Then Exit For
        Next dizisutun
       
    Next dizisatir
Range("D4").Resize(UBound(hedef, 1) + 1, sutun) = hedef
Erase kaynak: Erase hedef: sayac = Empty: dizisatir = Empty: dizisutun = Empty: sutun = Empty
End Sub