Birden Fazla Sütuna Göre Sıralama Yardım!

[ismailmuhcu]

Sevgili arkadaşlar, ekteki örnek çalışmamda 12 adet sütuna göre sıralama yapmam lazım, bu konuda yardımcı olabilir misiniz?

 

[Ferhat Pazarçevirdi]

Merhabalar

Sorunuzu tam olarak anlayamadım.

ilk olarak

(1) 1. departman, 1.kısımdan başlamak üzere

(2) giriş tutarları giriş sırasına göre alt alta,

(3) onun altına

(4) 1.departman 1.kısım çıkış tutarları sıra numarasına göre alt alta
gelmeli;

Yani, işlem bittikten sonra sıralama şu şekilde mi olacak?

D8-> 4
D9-> 3
D10-> 1

 

[ismailmuhcu]

Sıralama yaptıkdan sonra tablonun görünümüm ekteki gibi olmalı.

 

[Ferhat Pazarçevirdi]

Sıralamadan ziyade sanki hizalama gibi birşey anladım ben sorununuzu ...

Aşağıdaki kodu çalıştırınız.

Sub Sutunda_Sirala()
Dim arrG()
Dim arrC()
Dim x%, y%, i%, j%
For j = 4 To 21 Step 3
    For i = 8 To 37
        If Trim(Cells(i, j)) <> Empty Then
           y = y + 1
           ReDim Preserve arrG(1 To 2, 1 To y)
           arrG(1, y) = Cells(i, 3)
           arrG(2, y) = Cells(i, j)
           Cells(i, j) = Empty
        End If
        If Trim(Cells(i, j + 1)) <> Empty Then
           x = x + 1
           ReDim Preserve arrC(1 To 2, 1 To x)
           arrC(1, x) = Cells(i, 3)
           arrC(2, x) = Cells(i, j + 1)
           Cells(i, j + 1) = Empty
        End If
     Next i
Next j
Range("c8:c37").ClearContents
i = 8: y = 0
For j = 4 To 21 Step 3
    y = y + 1
    Cells(i, j) = arrG(2, y)
    Cells(i, 3) = arrG(1, y)
    Cells(i, j).Offset(1, 1) = arrC(2, y)
    Cells(i, 3).Offset(1, 0) = arrC(1, y)
    i = i + 2
Next j
End Sub

 

[ismailmuhcu]

Kodlar çalışıyor ama iş görmede ne yazık ki!
şöyleki ekteki tablo verdiğim örnekteki gibi değiştiğinde kodlar iş görmüyor
Revize edilmiş Sırala R1.xls dosyasındaki yenilenmiş veriler; yine revize edilmiş Sonuç Sıralaması R1.xls tablosundaki gibi olması gerektiği halde kodlar yanlış sonuç veriyor.

 

[Ferhat Pazarçevirdi]

Ama Sn.ismailmuhcu, ben de müneccim değilim ki ...

Gönderdiğiniz örneğe göre yaptık çalışmayı ...

Önceden şu örnekleri gönderseydiniz, bizde haliyle daha iyi kavrardık konuyu ...

Şaka bir yana, bakalım inceleyelim ... Çözeriz

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu çalıştırınız.

Sub Sutunda_Sirala()
Dim arrG()
Dim arrC()
Dim x%, y%, i%, j%, z%
For j = 4 To 21 Step 3
    For i = 8 To 37
        If Trim(Cells(i, j)) <> Empty Then
           y = y + 1
           ReDim Preserve arrG(1 To 4, 1 To y)
           arrG(1, y) = Cells(i, 3)
           arrG(2, y) = Cells(i, j)
           arrG(3, y) = j
           arrG(4, y) = Cells(i, 2)
           Cells(i, j) = Empty
        End If
        If Trim(Cells(i, j + 1)) <> Empty Then
           x = x + 1
           ReDim Preserve arrC(1 To 4, 1 To x)
           arrC(1, x) = Cells(i, 3)
           arrC(2, x) = Cells(i, j + 1)
           arrC(3, x) = j + 1
           arrC(4, x) = Cells(i, 2)
           Cells(i, j + 1) = Empty
        End If
     Next i
Next j
Range("b8:c37").ClearContents
z = 8
For j = 4 To 21 Step 3
    For i = 1 To y
        If arrG(3, i) = j Then
           Cells(z, arrG(3, i)) = arrG(2, i)
           Cells(z, 3) = arrG(1, i)
           Cells(z, 2) = arrG(4, i)
           arrG(2, i) = ""
           z = z + 1
        End If
    Next i
    For i = 1 To x
        If arrC(3, i) = j + 1 Then
           Cells(z, arrC(3, i)) = arrC(2, i)
           Cells(z, 3) = arrC(1, i)
           Cells(z, 2) = arrC(4, i)
           arrC(2, i) = ""
           z = z + 1
        End If
    Next i
Next j
End Sub

 

[Ferhat Pazarçevirdi]

İsteğiniz üzere, B sütunu da sıralamaya dahil edilmiştir.

7 nolu mesajdaki kodları revize ettim. İnceleyiniz.

 

[ismailmuhcu]

Çok teşekkürler, minnettarım...