Sıralama

[magnesia]

Arkadaşlar selam.
Bu konu ile ilgili forumda çok örnek var ama benim sorum biraz daha karışık.
Sayfadaki verileri alfabetik sıraya göre A'dan Z'ye sıralamak istiyorum.
Ancak veriler tek sütun halinde değil.

Verilerim;

B3-C69
F3-G69
J3-K69
N3-O69 hücreleri arasında.

Liste B3'ten başlayıp C69'da bitince F3'ten başlıyor. Bu liste de G69'da bitiyor. Devamı J3'ten başlayıp K69'da itiyor ve son olarak da N3'ten başlayıp O69'da bitiyor.

Araya veri girdiğimde sıralamayı alfabetik olarak tekrar yapsın ve kaydırsın istiyorum..

Örnek dosyada satır sayısını azalttım. Orijinalı 69. satırda bitiyor.
Umarım anlatabilmişimdir.
Şimdiden teşekkürler.

 

[magnesia]

Yardım lütfen

 

[magnesia]

SON BİR UMUTLA "lütfen" yardım.

 

[magnesia]

İlk kez böyle bir şey başıma geldi. Sorumu 100'e yakın kisi incelemiş fakat yanıt maalesef yok.

 

[ÖmerBey]

Merhaba,
Bu şekilde yapmak yerine başka bir sayfaya veri girişi yapıp kendi sayfanıza alsanız olmaz mı?
Diğer sayfada tek sütun halinde verinizi oluşturursunuz, istediğiniz eklemeyi veya çıkarmayı yapar, istediğiniz gibi sıralarsınız ve sonuçta da diğer sayfada tek sütun şeklinde sıraladığınız veriyi istediğiniz sırayla kullandığınız sayfaya çağırabilirsiniz.
İyi çalışmalar...

 

[magnesia]

Sayın mucit77
Çözüm gelmeyeceğinden emin olduktan sonra o şekilde yapmaya başladım zaten.

 

[ÖmerBey]

Sıralama için aşağıdaki kodları kullanabilirsiniz ama bana sorarsanız daha önce önerdiğim yöntemin yerini tutmaz.
Çözüm1: Sıralama için AY ve AZ sütunlarını kullanır.

Sub kod1()
Application.ScreenUpdating = False
Set alan = Range("B3:B7,F3:F7,J3:J7,N3:N7")
a = 0
For Each hcr In alan
    a = a + 1
    Cells(a, "AY").Value = hcr.Value
    Cells(a, "AZ").Value = hcr.Offset(0, 1).Value
Next
Range("AY:AZ").Sort Range("AY1"), xlAscending
alan.ClearContents
alan.Offset(0, 1).ClearContents
a = 0
For Each hcr In alan
    a = a + 1
    hcr.Value = Cells(a, "AY").Value
    hcr.Offset(0, 1).Value = Cells(a, "AZ").Value
Next
Range("AY:AZ").ClearContents
Application.ScreenUpdating = True
End Sub

Çözüm2:

Option Compare Text
Sub kod2()
Set alan = Range("B3:B7,F3:F7,J3:J7,N3:N7")
ReDim dz(alan.Cells.Count - 1, 2)
a = 0
For Each hcr In alan
    dz(a, 1) = hcr.Value
    dz(a, 2) = hcr.Offset(0, 1).Value
    a = a + 1
Next
For i = LBound(dz) To UBound(dz) - 1
    For j = i + 1 To UBound(dz)
        If dz(i, 1) > dz(j, 1) Then
            x1 = dz(i, 1)
            x2 = dz(i, 2)
            dz(i, 1) = dz(j, 1)
            dz(i, 2) = dz(j, 2)
            dz(j, 1) = x1
            dz(j, 2) = x2
        End If
    Next
Next
alan.ClearContents
alan.Offset(0, 1).ClearContents
a = 0
For Each hcr In alan
    Do While dz(a, 1) = ""
        a = a + 1
    Loop
    hcr.Value = dz(a, 1)
    hcr.Offset(0, 1).Value = dz(a, 2)
    a = a + 1
    If a > UBound(dz) Then Exit For
Next
End Sub

İyi çalışmalar...

 

[magnesia]

Sayın mucit77. Öncelikle ilgi ve emeğinize teşekkür ederim. Şu an dışarıdayım. Dönünce dener sonuçtan bilgi veririm

 

[magnesia]

Sayın mucit77.. İşlem tamam.. Tekrar teşekkür ederim. Yalnız ilginç bir durum meydana geldi.
Bu sayfadaki verilerde köprü vardı.. Köprülerin hepsi kalktı.. Sebebi ne olabilir? Çözümü var mıdır?

 

[ÖmerBey]

İlgili alandaki veriler temizlendiği için kalkmıştır.
Kod ile otomatik köprü ekleme yapılabilir.