Makro ile şarta bağlı toplama

Mdemir63 · 15 Haziran 2021

Selamlar
Arkadaşlar ekteki dosyada sonuç sarı alandaki gibi olacak .
Olmasını istediğim sonucu makro ile nasıl yapabilirim?

Saygılar

Orion1 · 15 Haziran 2021

J sütunundaki değerler sayı değil metin.
Size daha önce açıklamıştım.

Korhan Ayhan · 15 Haziran 2021

Deneyiniz.

Excelin yerleşik özelliklerini makroya uyarladım.

Benzersiz liste için "Yinelenenleri Kaldır" özelliğinden faydalandım.
Koşula göre toplama işlemi için "TOPLA.ÇARPIM" fonksiyonundan faydalandım.

C++:

Option Explicit

Sub Rapor()
    Dim Son As Long, Formul As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Range("K3:M" & Rows.Count).Clear
    Range("B3:B" & Cells(Rows.Count, "B").End(3).Row).Copy Range("K3")
    Range("K3:K" & Cells(Rows.Count, "K").End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
    Range("K3:M" & Rows.Count).Font.Size = 11
    Range("K3:M" & Rows.Count).Font.Name = "Calibri"
    
    Formul = "=SUMPRODUCT(($B$3:$B$1048576=K3)*(LEFT($J$3:$J$1048576,1)<>""+"")*(SUBSTITUTE(0&$J$3:$J$1048576,"" TL"","""")>0)*(SUBSTITUTE(SUBSTITUTE(0&$J$3:$J$1048576,"" TL"",""""),""+"","""")))"
    Son = Cells(Rows.Count, "B").End(3).Row
    Formul = Replace(Formul, 1048576, Son)
    
    With Range("L3:L" & Cells(Rows.Count, "K").End(3).Row)
        .Formula = Formul
        .Value = .Value
    End With

    Formul = "=SUMPRODUCT(($B$3:$B$1048576=K3)*(LEFT($J$3:$J$1048576,1)=""+"")*(SUBSTITUTE(SUBSTITUTE(0&$J$3:$J$1048576,"" TL"",""""),""+"","""")))"
    Son = Cells(Rows.Count, "B").End(3).Row
    Formul = Replace(Formul, 1048576, Son)
    
    With Range("M3:M" & Cells(Rows.Count, "K").End(3).Row)
        .Formula = Formul
        .Value = .Value
    End With

    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Mdemir63 · 15 Haziran 2021

Orion1' Alıntı:
J sütunundaki değerler sayı değil metin.
Size daha önce açıklamıştım.

Evren hocam
J sütununda değerlerin sayı olmadığını biliyorum. O yüzden yapamadım.

Mdemir63 · 15 Haziran 2021

@Korhan Ayhan Hocam
yine imdadıma yetiştiniz. Çok teşekkür ederim.

Saygılar

Ömer · 15 Haziran 2021

Merhaba,

Alternatif. + olmayanları - olarak düşünerek toplama dahil ettim.

Kod:

Sub topla()
 
    Dim i As Long, deg As String, d As Object, c As Integer, a1, a2, s, tpl As Double

    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False

    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        c = -1
        If Left(Cells(i, "J"), 1) = "+" Then c = 1
        tpl = CDbl(Replace(Cells(i, "J"), " TL", "")) * c
        If Not d.exists(deg) Then
            s = tpl
            d.Add deg, tpl
        Else
            s = d.Item(deg)
            s = s + tpl
            d.Item(deg) = s
        End If
    Next i
   
    Range("K3:M" & Rows.Count).ClearContents
    a1 = d.keys: a2 = d.items
    For i = 0 To d.Count - 1
        s = a2(i)
        Cells(i + 3, "K") = a1(i)
        If s < 0 Then
            Cells(i + 3, "L") = s * -1
        Else
            Cells(i + 3, "M") = s
        End If
    Next i
   
    Application.ScreenUpdating = True
    MsgBox "İşleminiz bitti.", vbInformation
   
End Sub

Korhan Ayhan · 15 Haziran 2021

Bu da dizi yöntemiyle alternatif olsun.

Hız olarak avantaj sağlayacaktır. Böylece excelin yerleşik özellikleri ile kod yazma tekniği ile arasında ki farkı kıyaslayabilirsiniz.

C++:

Option Explicit

Sub Rapor()
    Dim Veri As Variant, Son As Long, X As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "B").End(3).Row
    If Son < 4 Then Son = 4
    
    Veri = Range("A3:J" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 3)
    
    Range("K3:M" & Rows.Count).Clear
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, 2) <> "" Then
                If Not .exists(Veri(X, 2)) Then
                    Say = Say + 1
                    .Add Veri(X, 2), Say
                    Liste(Say, 1) = Veri(X, 2)
                    If Left(Veri(X, 10), 1) <> "+" Then
                        Liste(Say, 2) = CDbl(Replace(Veri(X, 10), " TL", ""))
                    Else
                        Liste(Say, 3) = CDbl(Replace(Replace(Veri(X, 10), " TL", ""), "+", ""))
                    End If
                Else
                    If Left(Veri(X, 10), 1) <> "+" Then
                        Liste(.Item(Veri(X, 2)), 2) = Liste(.Item(Veri(X, 2)), 2) + CDbl(Replace(Veri(X, 10), " TL", ""))
                    Else
                        Liste(.Item(Veri(X, 2)), 3) = Liste(.Item(Veri(X, 2)), 3) + CDbl(Replace(Replace(Veri(X, 10), " TL", ""), "+", ""))
                    End If
                End If
            End If
        Next
    End With
    
    If Say > 0 Then
        Range("K3").Resize(Say, 3) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
End Sub

Korhan Ayhan · 15 Haziran 2021

İki kod arasındaki farkı görebilmeniz için #3 nolu mesajımda ki koda zaman sayacı ekledim.

Benim bilgisayarımda iki kod arasında işlem süresi olarak 8-9 kat zaman farkı oluşuyor.

Orion1 · 15 Haziran 2021

Mdemir63' Alıntı:
Evren hocam
J sütununda değerlerin sayı olmadığını biliyorum. O yüzden yapamadım.

Niye metin oradaki değerler?

Mdemir63 · 15 Haziran 2021

Orion1' Alıntı:
Niye metin oradaki değerler?

Evren hocam
Sistemden excele aktar dediğimizde o şekilde aktarıyor

Korhan Ayhan · 15 Haziran 2021

Bu da ADO ile alternatif olsun.

"J" sütunu kod içinde düzenleniyor.

C++:

Option Explicit

Sub Rapor()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Range("K3:M" & Rows.Count).Clear
    
    If WorksheetFunction.CountIf(Range("J3:J" & Rows.Count), "* TL*") > 0 Then
        Range("J3:J" & Rows.Count).Replace "+", "-"
        Range("J3:J" & Rows.Count).Replace " TL", ""
        Range("J3:J" & Rows.Count).TextToColumns Destination:=Range("J3")
    End If

    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select F2,Sum(IIf(F10>0,F10,0)) As Borç,Sum(IIf(F10<0,F10,0)) As Alacak " & _
            "From [Sayfa1$A3:J] Where Not IsNull(F2) Group By F2 Order By F2 Asc"
    
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        Range("K3").CopyFromRecordset Kayit_Seti
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close

    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Mdemir63 · 15 Haziran 2021

@Korhan Ayhan Hocam @Ömer Hocam ayrı ayrı her ikinize de çok teşekkür ederim.

Saygılar

relaxim · 15 Haziran 2021

Korhan Ayhan' Alıntı:
İki kod arasındaki farkı görebilmeniz için #3 nolu mesajımda ki koda zaman sayacı ekledim.

Benim bilgisayarımda iki kod arasında işlem süresi olarak 8-9 kat zaman farkı oluşuyor.

Hocam ben de test ettim. Birincisi 98 saniye ikincisi 6 saniye müthiş....

Makro ile şarta bağlı toplama

Mdemir63

Ekli dosyalar

Orion1

Uzman

Korhan Ayhan

Administrator

Mdemir63

Mdemir63

Ömer

Moderatör

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Orion1

Uzman

Mdemir63

Korhan Ayhan

Administrator

Mdemir63

relaxim