Sıralama

[EGZELL]

selam arkadaşlar,

sıralama ile ilgili bir sorunum var. sitedeki sıralama uygulamalarını denedim ama istediğim gibi olmadı. yardım ederseniz çok sevinirim.

örnek ektedir.

 

[Necdet]

Merhaba,

Önce sıralama sorusunu yaptım, sonra baktım ki sayfa1 den gelen verileri düzenlemekte varmış. Düzenlemeyi de yapınca iki ayrı yordum oldu, aslında tek seferde yapılabilinirdi.

Tek Sub ile de olabilirdi.

Sub SIRALA()
    Dim Deger   As String, _
        Bas     As Integer, _
        Bit     As Integer, _
        i       As Integer
 
    Application.ScreenUpdating = False
 
    Deger = Range("B[B][COLOR=red]2[/COLOR][/B]")
    Bas =[COLOR=red][B] 2[/B][/COLOR]
 
    For i = [COLOR=red][B]2[/B][/COLOR] To Cells(Rows.Count, "B").End(3).Row + 1
            If Not Cells(i, "B") = Deger Then
            Deger = Cells(i, "B")
            Bit = i - 1
            Range(Cells(Bas, "E"), Cells(Bit, "G")).Sort Key1:=Cells(Bas, "F"), Order1:=xlAscending
            Bas = Bit [COLOR=red][B]+ 1[/B][/COLOR]
        End If
    Next i
 
    Application.ScreenUpdating = True
    MsgBox "SIRALAMA BİTMİŞTİR...", vbInformation, "N. YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

Sub DUZENLE()
    Dim i   As Integer, _
        j   As Integer, _
        k   As Integer, _
        Kol As Integer, _
        s1  As Worksheet, _
        s2  As Worksheet
 
    Set s1 = Sheets("Veri")
    Set s2 = Sheets("Sonuc")
 
    Kol = s1.Cells(3, Columns.Count).End(1).Column
 
    s2.Select
    Application.ScreenUpdating = False
    Cells.ClearContents
 
    s1.Range("A2:D2").Copy Range("A1")
    Range("E1") = "FİRMA"
    Range("F1") = "BİRİM FİYATI"
    Range("G1") = "TOPLAM FİYATI"
    j = 1
 
    For i = 4 To s1.Cells(Rows.Count, "A").End(3).Row
        For k = 5 To Kol
            j = j + 1
            s1.Range("A" & i & ":D" & i).Copy Cells(j, "A")
            Cells(j, 5) = s1.Cells(3, k)
            Cells(j, 6) = s1.Cells(i, k)
            Cells(j, 7) = "=F" & j & "*C" & j
        Next k
    Next i
 
    Application.ScreenUpdating = True
    SIRALA
 
End Sub

 

[EGZELL]

sayın Necdet Yeşertener,

öncelikle sorum ile ilgilendiğiniz ve zaman ayırdığınız için çok teşekkür ederim.
yazdığınız kodu uyguladım. düzenle butonuna basınca ufak bir hata veriyor. yani küçükten büyüğe doğru sıralamada bir hata var. hatayı ekteki dosyada yükledim. ilgilenirseniz sevinirim.

yardımlarınız için şimdiden çok teşekkür ederim.

 

[Necdet]

Merhaba,

Gereksiz Satır ve Sütunları silince kodlardaki değişikliği unutmuşum.

Yukarıdaki kırmızı işaretlenen değişiklikler (-ki bir incekinde hep 3 tü) yapıldığında sorun olmayacaktır.

Dosya ve Kodlar güncellenmiştir, Güle güle kullanınız.

 

[EGZELL]

Necdet hocam,

kodlardaki düzeltmeyi yaptım ama yine olması gereken tabloyu oluşturmuyor.
yani Elma için, Ahmet (1 tl), Mehmet (2 tl), Ali (3 tl), Veli (4 tl), şeklinde sıralama yapması gerekirken, sıralama da bir hata yapıyor.

bir de ben bu kodu, 3000 tane sıra no , ve 250 tane firma için nasıl uyarlayabilirim.

yardımlarınız için teşekkür ederim.

 

[Necdet]

Merhaba,

Evet küçük bir hata yapmışım, yukarıdaki kod ve dosyayı yineledim, inceler misiniz?

 

[EGZELL]

Sayın Necdet Hocam,

ellerinize aklınıza sağlık, kodlar bu hali ile bile çok işime yarayacak.
iki gündür uğraşıyorum yalnız ben bu örneği benim 3000 adet malzeme ve 250 adet firmalık asıl tabloma uygulayamadım. sistem çok ağırlaşıyor ve sonra hesaplama yapmadan hata veriyor.

ilginiz ve sabrınız için teşekkür ederim.

 

[EGZELL]

çalışma ile ilgili örnek ekledim. kod da ufak bir değişiklikle sorun çözülür kanaatindeyim.

yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,

Kodları yeniledim, birleştirdim.

Denemelerim doğru çalıştı ama siz yine de bir kontrol ediniz.

Sub Duzenle_Sirala()

    Dim i   As Integer, _
        j   As Integer, _
        k   As Integer, _
        Bs  As Integer, _
        Bt  As Integer, _
        Kol As Integer, _
        Deg As String, _
        s1  As Worksheet, _
        s2  As Worksheet
    
    Set s1 = Sheets("Veri")
    Set s2 = Sheets("Sonuc")
        
    'Sayfadaki Son Kolon Numarası Bulunur, Bu Nedenle Fira Sayısı Önemli Değil
    Kol = s1.Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
    Application.ScreenUpdating = False
    s2.Select
    Cells.ClearContents
    
    s1.Range("A2:D2").Copy Range("A1")
    Range("E1") = "FİRMA"
    Range("F1") = "BİRİM FİYATI"
    Range("G1") = "TOPLAM FİYATI"
    
    Deg = s1.Range("B4")
    Bs = 2
    j = 1
    
    For i = 4 To s1.Cells(Rows.Count, "A").End(3).Row + 1
    
        If Not s1.Cells(i, "B") = Deg Then
            Bt = j
            'Sıralama Yapılıyor
            Range(Cells(Bs, "E"), Cells(Bt, "G")).Sort Key1:=Cells(Bs, "F")
            Bs = j + 1
        End If
            
        For k = 5 To Kol
        
            If s1.Cells(i, k) > "" Then
                j = j + 1
                s1.Range("A" & i & ":D" & i).Copy Cells(j, "A")
                Cells(j, 5) = s1.Cells(3, k)
                Cells(j, 6) = s1.Cells(i, k)
                Cells(j, 7) = "=F" & j & "*C" & j
            End If
            
        Next k
        
    Next i
    
    Columns("F:G").NumberFormat = "#,##0.00"
        
    MsgBox "DÜZENLEME Ve SIRILAMA BİTMİŞTİR....", vbInformation, "N. YEŞERTENER ---> www.excel.web.tr"
    
End Sub

 

[EGZELL]

Allah razı olsun Hocam,
bu kod sayesinde 1 haftalık işimiz 1 dk' da yanlışsız halloluyor.
ellerinize, aklınıza sağlık...

 

[Necdet]

Allah razı olsun Hocam,
bu kod sayesinde 1 haftalık işimiz 1 dk' da yanlışsız halloluyor.
ellerinize, aklınıza sağlık...

Güle güle kullanınız.