Kolonlara Alfabetik Sıralama

[baydeniro]

Merhaba arkadaşlar. A kolonundaki verileri C den başlayarak sağa doğru ilk harflerinin kolonların 1. hücresindeki harfler ile eşleşiyor ise gruplayarak sıralatabilir miyiz ? Ekteki dosya konu ile ilgili 2 versiyon durumu var. Yardımcı olanlara çok teşekkürler.

 

[Orion1]

Merhaba.
Versiyon 1 için hazırladım .
Ekli dosyayı inceleyiniz.

Sub sirala()
Dim i As Long, adr1, adr2 As String, k As Integer, sayac As Byte
Dim harf As String, son As Long, sut As Integer
Sheets("1 VERSIYON").Select
Application.ScreenUpdating = False
Range("B1:B65536").ClearContents
Range("C1:IV65536").ClearContents
adr1 = Range(Cells(1, "A"), Cells(Cells(65536, "A").End(xlUp).Row, "A")).Address
adr2 = Range(Cells(1, "B"), Cells(Cells(65536, "A").End(xlUp).Row, "B")).Address
Range(adr2).Value = Range(adr1).Value
Range("B1:B65536").Sort Range("B1")
For i = 1 To Cells(65536, "B").End(xlUp).Row
    harf = Left(Cells(i, "B").Value, 1)
    For k = 3 To 256
        If Left(Cells(1, k).Value, 1) = harf Then
            sonsat = Cells(65536, k).End(xlUp).Row + 1
            Cells(sonsat, k).Value = Cells(i, "B").Value
            sayac = 1
            Exit For
        End If
    Next
    If sayac = 0 Then
        sut = Cells(1, 256).End(xlToLeft).Column + 1
        Cells(1, sut).Value = Cells(i, "B").Value
    End If
    sayac = 0
Next
Range("B1:B65536").ClearContents
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAMLANDI..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[baydeniro]

Çok Teşekkürler

Orion2 yardımınız için çok teşekkürler. 1. Versiyon tamamdır.

 

[Necdet]

Merhaba,

2. Sürüm de benden olsun. Sayın Orion2 nin dosyasına ek olarak.

Public Sub Versiyon2_Sirala()
Application.ScreenUpdating = False
Set S2 = Sheets("2 VERSIYON")
S2.Select
[C1:IV65536].ClearContents
[C1:IV1].Font.Bold = True
Range("A1:A" & [A65536].End(3).Row).Copy [B1]
Range("B1:B" & [B65536].End(3).Row).Sort key1:=[B1]
Kolon = 2
For i = 1 To [B65536].End(3).Row
    
    If Left(Cells(i, "B"), 1) <> Ilk_Harf Then
       Kolon = Kolon + 1
       Satır = 2
       Ilk_Harf = Left(Cells(i, "B"), 1)
       Cells(1, Kolon) = Ilk_Harf
    End If
    
    Cells(Satır, Kolon) = Cells(i, "B")
    Satır = Satır + 1
Next i
[B1:B65536].ClearContents
End Sub

 

[Necdet]

Merhaba,

Tek Modülde, her iki şartta çalışan hali ekte.

Public Sub Versiyon2_Sirala()
Yanıt = Application.InputBox("1 --> Versiyon 1 (Başlıksız), 2--> Versiyon 2 (Başlıklı)", "Neye Göre Listelemek istiyorsunuz", 1, , , , , 1)
Application.ScreenUpdating = False
[C1:IV100].ClearContents
If Yanıt = 2 Then
   [C1:IV1].Font.Bold = True
   [C1:IV1].HorizontalAlignment = xlCenter
Else
   [C1:IV1].Font.Bold = False
   [C1:IV1].HorizontalAlignment = xlLeft
End If
Range("A1:A" & [A65536].End(3).Row).Copy [B1]
Range("B1:B" & [B65536].End(3).Row).Sort key1:=[B1]
Kolon = 2
For i = 1 To [B65536].End(3).Row
    
    If Left(Cells(i, "B"), 1) <> Ilk_Harf Then
            Kolon = Kolon + 1
            Ilk_Harf = Left(Cells(i, "B"), 1)
       
            If Yanıt = 2 Then
                    Satır = 2
                    Cells(1, Kolon) = Ilk_Harf
            Else
                    Satır = 1
            End If
    End If
    
    Cells(Satır, Kolon) = Cells(i, "B")
    Satır = Satır + 1
Next i
[B1:B65536].ClearContents
End Sub

 

[baydeniro]

Çok Teşekkürler

Sayın Necdet Yesertener yardımlarınız için çok teşekkürler. Sizin 2. çalışmanızı incelerken aklıma geldi. Harflere endeksli olmayan, belli bir sayıya göre verilere kolonlara bölen 3. bir versiyon ekleyebilir miyiz !! Yani her bir kolona 5 adet veri ataması yapılabilir mi !!!

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.

Sub grup_sirala()
Dim i As Long, sat As Byte, sut As Integer
Sheets("3 VERSIYON").Select
Application.ScreenUpdating = False
Range("C1:IV65536").ClearContents
sat = 1: sut = 3
For i = 1 To Cells(65536, "A").End(xlUp).Row
    If sat > 5 Then sut = sut + 1: sat = 1
    Cells(sat, sut).Value = Cells(i, "A").Value
    sat = sat + 1
Next
Application.ScreenUpdating = True
MsgBox "GRUPLAMA TAMAMLANDI..!!", vbOKOnly + vbInformation
End Sub

 

[baydeniro]

Orion2, çok çok teşekkürler. Şimdi 3 versiyon ile birlikte harika bir dosya oldu. Hepinize çok teşekkürler, elleriniz dert görmesin. Sağlıcakla kalın.

 

[Orion1]

Orion2, çok çok teşekkürler. Şimdi 3 versiyon ile birlikte harika bir dosya oldu. Hepinize çok teşekkürler, elleriniz dert görmesin. Sağlıcakla kalın.

Rica ederim.
İyi çalışmalar.

 

[Necdet]

Son noktayı Sayın Orion2 koymuş, eline sağlık, her kolonda listelenecek satır sayısını da parametrik olsa sanırım daha kullanışlı olabilir, ben topu attım Sayın Orion2'ye .

Güle güle kullanınız Sayın serdarokan, sayenizde bende kod yazmayı geliştiriyorum.

Bende size teşekkür ederim.

 

[baydeniro]

Sayın Necdet Yesertener, Orion2, Cost Control, leventm, Ali, seyit tiken, hamitcan, ileriexcel ve emeği ve yardımı geçen tüm uzman arkadaşlara çok çok teşekkürler. Sizlerin sayesinde hem bir şeyler öğreniyor, hem de pek çok sorunumuzu çözüyoruz. İyi ki varsınız. Sizlerin kod yazmanıza minik te olsa bizim de bir katkımız oluyorsa ne mutlu bizlere. Tekrar teşekkürler.