Makroda 3 farklı sayfadan Veri Süzme

[erseljti]

Sevgili Üstadlarım,
Çalışmam Genel anlamda 3 farklı sayfadaki verileri Data sayfamda birleştirmek.
Burada Bayi kodu mantığını esas alarak aynı bayi koduna ait verileri Data sayfamda sıralamak.
Detaylı anlatım EK te mevcut.
İlgi ve alakanızı esirgemeyeceğiniz düşüncesiyle
Emek verecek üstadlarıma şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub AKTAR()
    Dim WF As WorksheetFunction
    Dim S1 As Worksheet, S2 As Worksheet
    Dim S3 As Worksheet, S4 As Worksheet
    Dim X As Long, Satir As Long
    Dim Bul_1 As Range, Bul_2 As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Stand")
    Set S3 = Sheets("Borç Yaş")
    Set S4 = Sheets("Vade Gün")
    Set WF = WorksheetFunction
    
    S1.Range("A4:U65536").ClearContents
    
    Satir = 4
        
    For X = 2 To S2.Cells(Rows.Count, 1).End(3).Row
        If S2.Cells(X, "I") = "Aktif" And S2.Cells(X, "J") = "Normal" Then
            If WF.CountIf(S1.Range("C:C"), S2.Cells(X, "A")) = 0 Then
                S1.Cells(Satir, 1) = S2.Cells(X, "I")
                S1.Cells(Satir, 2) = S2.Cells(X, "J")
                S1.Cells(Satir, 3) = CDbl(S2.Cells(X, "A"))
                S1.Cells(Satir, 4) = S2.Cells(X, "B")
                S1.Cells(Satir, 5) = S2.Cells(X, "C")
                S1.Cells(Satir, 6) = S2.Cells(X, "D")
                S1.Cells(Satir, 7) = S2.Cells(X, "BD")
                
                Set Bul_1 = S3.Range("A:A").Find(S1.Cells(Satir, 3), , , xlWhole)
                If Not Bul_1 Is Nothing Then
                    S1.Cells(Satir, 8) = S3.Cells(Bul_1.Row, "S")
                End If
                
                Set Bul_2 = S4.Range("A:A").Find(S1.Cells(Satir, 3), , , xlWhole)
                If Not Bul_2 Is Nothing Then
                    S1.Cells(Satir, 9) = S4.Cells(Bul_2.Row, "H")
                    S1.Cells(Satir, 10) = S4.Cells(Bul_2.Row, "J")
                    S1.Cells(Satir, 11) = S4.Cells(Bul_2.Row, "L")
                    S1.Cells(Satir, 12) = S4.Cells(Bul_2.Row, "N")
                    S1.Cells(Satir, 13) = S4.Cells(Bul_2.Row, "P")
                    S1.Cells(Satir, 14) = S4.Cells(Bul_2.Row, "R")
                    S1.Cells(Satir, 15) = S4.Cells(Bul_2.Row, "T")
                    S1.Cells(Satir, 16) = S4.Cells(Bul_2.Row, "V")
                    S1.Cells(Satir, 17) = S4.Cells(Bul_2.Row, "X")
                    S1.Cells(Satir, 18) = S4.Cells(Bul_2.Row, "Z")
                    S1.Cells(Satir, 19) = S4.Cells(Bul_2.Row, "AB")
                    S1.Cells(Satir, 20) = S4.Cells(Bul_2.Row, "AE")
                    S1.Cells(Satir, 21) = S4.Cells(Bul_2.Row, "AI")
                End If
                
                Satir = Satir + 1
            End If
        End If
    Next
        
    For X = S1.Cells(Rows.Count, 1).End(3).Row To 4 Step -1
        If S1.Cells(X, "I") = 0 Then S1.Rows(X).Delete
    Next
        
    S1.Range("A4:A65536").EntireRow.Sort Key1:=S1.Range("H4"), Order1:=xlDescending
        
    Set Bul_1 = Nothing
    Set Bul_2 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set WF = Nothing
        
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[erseljti]

Hocam desteğiniz için ne kadar teşekkür etsem azdır. Tam istediğim sonucu alabildim.Gönderdiğiniz Makroda çok az bir değişim yaptım.
Çalışmamı tamamlamam için 2 sorun karşıma çıktı.
*Data sayfasında I sutununda (Müşteri Bakiyesi Başlıklı) sonucu 0 çıkan tüm satırların silinmesi
*Bu satırlar silindikten sonra Data sayfasında H sutunundaki (Ort Başlıklı) alandaki verÖilere göre tüm Bayilerin yüksekten küçüğe doğru sıralaması
Örnek...
98
97
96
gibi
Ekte tabloyu açarsanız Data sutununda Manuel olarak istediğimi yaptım(I sutununa Manuel olarak zden Aya doğru sırala dedim)Bunu makronun yapmasını istiyorum)
Lütfen bu konudada yardımlarınızı esirgemeyiniz.
Teşekkürler

 

[Korhan Ayhan]

Merhaba,

Üstteki mesajımdaki kodu güncelledim. Denermisiniz.

 

[assenucler]

Sayın erseljti,
Sayın Korhan Ayhan,


Bu çalışma dosyası ve üstadımın değerli katkıları ile çok güzel bir "borç yaşlandırma" çalışması ortaya çıktı.

Emeği geçen sizlere sonsuz teşekkürler.

Sevgi ve saygılar.

 

[erseljti]

Korhan bey desteğiniz için ne kadar teşekkür etsem azdır.