Saate Gore Siralama Yapilabilirmi...

[rekkezum]

Degerli Hocalarim Merhaba ...
Ekteki Dosyada Verilen Seferler, Kalkis Saatleri Ve Sefer Numaralari Mevcut Sefer Ve Sefer Numaralari Degismeden Saat Sirasina Gore Asagidan Yukari Siralamak Mumkunmudur Acaba..
Haftanin Yedi Gunune Ait Siralamadir Ekteki Dosyadakiler.
Yardimci Olanlara Simdiden Tesekkurler...

 

[rekkezum]

Degerli Hocalarim Merhaba ...
Ekteki Dosyada Verilen Seferler, Kalkis Saatleri Ve Sefer Numaralari Mevcut Sefer Ve Sefer Numaralari Degismeden Saat Sirasina Gore Asagidan Yukari Siralamak Mumkunmudur Acaba..
Haftanin Yedi Gunune Ait Siralamadir Ekteki Dosyadakiler.
Yardimci Olanlara Simdiden Tesekkurler...

AYNI ZAMANDA SAYFA2 E PAZARTESI SAYFA3 YE SALI PAZARA KADAR BI DUGME ILE GUNLUK LISTE OLUSTURMAK MUMKUNMUDUR ACABA...

 

[Ferhat Pazarçevirdi]

Merhabalar

Aşağıdaki kodu standart bir modül sayfasına kopyalayıp çalıştırınız.

Sub Siralama()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim arrGun()
Dim arrGunler()
Dim j%, y%, a%, i%, m%, n%, t%
Dim z1, z2, z3
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
arrGunler = Array("Pazartesi", "Salı", "Çarşamba", "Perşembe", "Cuma", "Cumartesi", "Pazar")
sh2.Cells.ClearContents
For j = 3 To 15 Step 2
    a = a + 1
    For i = 4 To sh1.Cells(65536, j).End(xlUp).Row
        If Trim(sh1.Cells(i, j)) <> Empty Then
           y = y + 1
           ReDim Preserve arrGun(1 To 3, 1 To y)
           arrGun(1, y) = sh1.Cells(i, 1)
           arrGun(2, y) = sh1.Cells(i, j)
           arrGun(3, y) = sh1.Cells(i, j - 1)
        End If
    Next i
    For m = 1 To y
        For n = m + 1 To y
            If arrGun(2, m) > arrGun(2, n) Then
               z1 = arrGun(2, m)
               z2 = arrGun(1, m)
               z3 = arrGun(3, m)
               arrGun(2, m) = arrGun(2, n)
               arrGun(1, m) = arrGun(1, n)
               arrGun(3, m) = arrGun(3, n)
               arrGun(2, n) = z1
               arrGun(1, n) = z2
               arrGun(3, n) = z3
            End If
        Next n
    Next m
        sh2.Cells(1, a) = arrGunler(t)
        For i = 2 To y
            sh2.Cells(i, a) = arrGun(2, i - 1)
            sh2.Cells(i, a + 1) = arrGun(3, i - 1)
            sh2.Cells(i, a + 2) = arrGun(1, i - 1)
        Next i
     a = a + 2
     y = 0
     Erase arrGun
     t = t + 1
Next j
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

 

[rekkezum]

Merhabalar

Aşağıdaki kodu standart bir modül sayfasına kopyalayıp çalıştırınız.

Sub Siralama()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim arrGun()
Dim arrGunler()
Dim j%, y%, a%, i%, m%, n%, t%
Dim z1, z2, z3
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
arrGunler = Array("Pazartesi", "Salı", "Çarşamba", "Perşembe", "Cuma", "Cumartesi", "Pazar")
sh2.Cells.ClearContents
For j = 3 To 15 Step 2
    a = a + 1
    For i = 4 To sh1.Cells(65536, j).End(xlUp).Row
        If Trim(sh1.Cells(i, j)) <> Empty Then
           y = y + 1
           ReDim Preserve arrGun(1 To 3, 1 To y)
           arrGun(1, y) = sh1.Cells(i, 1)
           arrGun(2, y) = sh1.Cells(i, j)
           arrGun(3, y) = sh1.Cells(i, j - 1)
        End If
    Next i
    For m = 1 To y
        For n = m + 1 To y
            If arrGun(2, m) > arrGun(2, n) Then
               z1 = arrGun(2, m)
               z2 = arrGun(1, m)
               z3 = arrGun(3, m)
               arrGun(2, m) = arrGun(2, n)
               arrGun(1, m) = arrGun(1, n)
               arrGun(3, m) = arrGun(3, n)
               arrGun(2, n) = z1
               arrGun(1, n) = z2
               arrGun(3, n) = z3
            End If
        Next n
    Next m
        sh2.Cells(1, a) = arrGunler(t)
        For i = 2 To y
            sh2.Cells(i, a) = arrGun(2, i - 1)
            sh2.Cells(i, a + 1) = arrGun(3, i - 1)
            sh2.Cells(i, a + 2) = arrGun(1, i - 1)
        Next i
     a = a + 2
     y = 0
     Erase arrGun
     t = t + 1
Next j
Set sh1 = Nothing
Set sh2 = Nothing
End Sub

hocam ben beceremedım galıba ekte ufak bır dosya gonderdım bakabılırmısınız...

 

[Ferhat Pazarçevirdi]

Ekteki dosyayı inceleyiniz.

Sırala butonuna bastıktan sonra, Sayfa2'de raporu görebilirsiniz.

 

[rekkezum]

fcp hocam ellerıne saglık ta sırala dugmesıne bastıgımda bır uyarı vermekte sebebı ne olabılır... dosya ısmını save edıp ısmını de degıstırdım deneme.xls olarak ama olmadı...yardım edermısınız...

 

[Ferhat Pazarçevirdi]

5.mesajdaki dosyayı yeniden indirip, deneyiniz...

 

[rekkezum]

hocam mukemmel olmus ellerıne saglık. allah basımızdan eksık etmesın bılgılı ınsanları ...

 

[Ferhat Pazarçevirdi]

Estağfurullah, işinize yaramasına sevindim. İyi çalışmalar