Makro ile şarta bağlı toplama

[Mdemir63]

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

Saygılar

 

[Orion1]

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

 

[Korhan Ayhan]

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.

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]

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]

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

Saygılar

 

[Ömer]

Merhaba,

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

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]

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.

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]

İ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]

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

Niye metin oradaki değerler?

 

[Mdemir63]

Niye metin oradaki değerler?

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

 

[Korhan Ayhan]

Bu da ADO ile alternatif olsun.

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

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]

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

Saygılar

 

[relaxim]

İ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ş....