Verileri diğer sayfada gösterilmesi hk.

[1903emre34@gmail.com]

Merhaba,

Sayfa1'de "B" sütünda yer alan ara toplam 100, ara toplam 102 vs karşısında yer alan tutarların (I sütün), pozitif ise buraya Borç bakiyesini altına, tutar negatif ise Alacak bakiyesinin altına yerleştirilmesi için nasıl kod oluşturabiliriz, istenen sayfa2'de yapılmıştır.

 

[Korhan Ayhan]

Formülle yapabilirsiniz.

E6;

=EĞER(DÜŞEYARA("Ara Toplam "&D6;Sayfa1!B:I;8;0)>0;DÜŞEYARA("Ara Toplam "&D6;Sayfa1!B:I;8;0);0)

F6;

=EĞER(DÜŞEYARA("Ara Toplam "&D6;Sayfa1!B:I;8;0)<0;-1*DÜŞEYARA("Ara Toplam "&D6;Sayfa1!B:I;8;0);0)

 

[1903emre34@gmail.com]

İlginiz için teşekkürler, sayfa2'de yer alan hesap kodları manuel yazıyorum, makro ile hem hesap kodları hem de tutarları gelmesi için kod yapabilir miyiz

 

[Korhan Ayhan]

Deneyiniz.

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul As Range, Adres As String, Satir As Integer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Range("D6:F" & Rows.Count).ClearContents
    
    Aranan = "Ara toplam ???"
    Satir = 6
    
    Set Bul = S1.Range("B:B").Find(Aranan, , , xlWhole)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            S2.Cells(Satir, "D") = Bul.Value
            If Bul.Offset(0, 7) > 0 Then
                S2.Cells(Satir, "E") = Bul.Offset(0, 7)
            Else
                S2.Cells(Satir, "F") = Bul.Offset(0, 7) * -1
            End If
            Satir = Satir + 1
            Set Bul = S1.Range("B:B").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
    
    S2.Range("D:D").Replace "Ara toplam ", "", xlPart
    S2.Range("D:F").EntireColumn.AutoFit

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[1903emre34@gmail.com]

Teşekkürler, çalışıyor.

 

[1903emre34@gmail.com]

Korhan hocam, örnek dosyada çalıştı, Ara toplam 3 10 Ara toplam 2 102 olunca kodları ve tutarları sayfa2 aktarması için kodlarda değişiklik yapabilir miyiz

 

[Korhan Ayhan]

Verilerinizde tekrar etme durumu var mı? Varsa bu veriler toplanacak mı?

 

[1903emre34@gmail.com]

Tekrar etme durumu var sadece ara toplam 2 100 olanların yanındaki tutarların I sütünü sayfa2 e aktarılması için değişiklik yapabilir misniz

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Aranan As String, X As Long
    Dim Bul As Range, Adres As String, Satir As Integer
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
   
    Son = S1.Cells(Rows.Count, "B").End(3).Row
    S2.Range("D6:F" & Rows.Count).ClearContents
   
    Aranan = "Ara toplam *"
    Satir = 6
   
    For X = 5 To Son
        If S1.Cells(X, "B") Like Aranan Then
            If WorksheetFunction.CountIf(S2.Range("D:D"), S1.Cells(X, "B")) = 0 Then
                S2.Cells(Satir, "D") = S1.Cells(X, "B")
                If S1.Cells(X, "I") > 0 Then
                    S2.Cells(Satir, "E") = S1.Cells(X, "I")
                Else
                    S2.Cells(Satir, "F") = S1.Cells(X, "I") * -1
                End If
                Satir = Satir + 1
            Else
                Set Bul = S2.Range("D:D").Find(S1.Cells(X, "B"), , , xlWhole)
                If Not Bul Is Nothing Then
                    If S1.Cells(X, "I") > 0 Then
                        S2.Cells(Bul.Row, "E") = S2.Cells(Bul.Row, "E") + S1.Cells(X, "I")
                    Else
                        S2.Cells(Bul.Row, "F") = S2.Cells(Bul.Row, "E") + S1.Cells(X, "I") * -1
                    End If
                End If
            End If
        End If
    Next
   
    S2.Range("D:D").Replace "Ara toplam ", "", xlPart
    S2.Range("D:F").EntireColumn.AutoFit

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[1903emre34@gmail.com]

Dosyayı ekledim, tutarlarda bir sorun yok.

 

[Korhan Ayhan]

Siz sonu 3 karakterle biten satırların özetini mi istiyorsunuz?

 

[1903emre34@gmail.com]

Evet, hesap kodları sayfa 2'e 100,102 olarak.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Son As Long, Aranan As String, X As Long, Kod As String
    Dim Bul As Range, Adres As String, Satir As Integer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Son = S1.Cells(Rows.Count, "B").End(3).Row
    S2.Range("D6:F" & Rows.Count).ClearContents
    
    Aranan = "Ara toplam *"
    Satir = 6
    
    For X = 5 To Son
        If Len(S1.Cells(X, "B")) = 16 Then
            Kod = Right(S1.Cells(X, "B"), 3)
            If S1.Cells(X, "B") Like Aranan Then
                If WorksheetFunction.CountIf(S2.Range("D:D"), Kod) = 0 Then
                    S2.Cells(Satir, "D") = Kod
                    If S1.Cells(X, "I") > 0 Then
                        S2.Cells(Satir, "E") = S1.Cells(X, "I")
                    Else
                        S2.Cells(Satir, "F") = S1.Cells(X, "I") * -1
                    End If
                    Satir = Satir + 1
                Else
                    Set Bul = S2.Range("D:D").Find(Kod, , , xlWhole)
                    If Not Bul Is Nothing Then
                        If S1.Cells(X, "I") > 0 Then
                            S2.Cells(Bul.Row, "E") = S2.Cells(Bul.Row, "E") + S1.Cells(X, "I")
                        Else
                            S2.Cells(Bul.Row, "F") = S2.Cells(Bul.Row, "E") + S1.Cells(X, "I") * -1
                        End If
                    End If
                End If
            End If
        End If
    Next
    
    S2.Range("D:D").Replace "Ara toplam ? ??", "", xlPart
    S2.Range("D:F").EntireColumn.AutoFit

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub