TOPLA.ÇARPIM yerine ÇOKETOPLA veya Makro

[Mesafe]

İlişikteki örnekte TOPLA.ÇARPIM formülü ile yapılan hesaplama ÇOKETOPLA veya Makro ile de yapılabilir mi ?

 

[Ömer]

Merhaba,

Çalşma sayfasının kod bölümüne kopyalayınız. H2 deki değer değiştiğinde kod çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, i As Byte, j As Byte
    Dim ilko As String, ilkt As String, sont As String, sono As String
 
    If Intersect(Target, [H2]) Is Nothing Then Exit Sub
 
    Range("I3:P8").ClearContents
 
    For i = 3 To 8
        With Range("A:A")
            Set c = .Find(Cells(i, "G"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    ilkt = UCase(Replace(Replace(Format(Cells(c.Row, "C"), "mmmm") _
                        , "ı", "I"), "i", "İ"))
                    ilko = UCase(Replace(Replace(Range("H2"), "ı", "I"), "i", "İ"))
                    If ilkt = ilko Then
                        For j = 9 To 16
                            sont = UCase(Replace(Replace(Format(Cells(c.Row, "D"), "mmmm") _
                                , "ı", "I"), "i", "İ"))
                            sono = UCase(Replace(Replace(Cells(2, j), "ı", "I"), "i", "İ"))
                            If sont = sono Then
                                Cells(i, j) = Cells(i, j) + Cells(c.Row, "B")
                            End If
                        Next j
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
    Next i
 
End Sub

.

 

[Mesafe]

Hocam emekleriniz için sonsuz teşekkürler, Ancak bu kodları ben kendi orjinal dosyama uyarlayamadım, veriler ve sonuç aynı sayfada olmadığı için sanırım beceremedim.
Rica etsem ilişikteki dosyama uyarlayabilir veye nerede hata yaptığım konusunda uyarıda bulunabilirmisiniz.
Tekrar teşekkürler.

 

[Ömer]

Öncelikle Modul ve Sayfadaki Eski tüm kodları silin.

Daha sonra modul1' e;

Sub OZET_Picture1_Tıklat()
    Sheets("OZET").Select
    Range("A2:M" & Rows.Count).ClearContents
End Sub

Sub Picture1_Tıklat()
    Dim Sd As Worksheet, son As Long
    
    Set Sd = Sheets("DATA")
    Sheets("OZET").Select
    
    son = Sd.Cells(Rows.Count, "A").End(xlUp).Row
    
    Application.ScreenUpdating = False
    
    Range("A:A").ClearContents
    
    Sd.Range("A11:A" & son).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=Range("A1"), Unique:=True
    
    Application.ScreenUpdating = True
 
End Sub

OZET sayfası kod bölümüne;

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim c As Range, Adr As String, i As Byte, j As Byte, Sd As Worksheet
    Dim ilko As String, ilkt As String, sont As String, sono As String
 
    If Intersect(Target, [C1]) Is Nothing Then Exit Sub
 
    Set Sd = Sheets("DATA")
 
    Application.ScreenUpdating = False
    Range("C2:M" & Rows.Count).ClearContents
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        With Sd.Range("A:A")
            Set c = .Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    ilkt = UCase(Replace(Replace(Format(Sd.Cells(c.Row, "E"), "mmmm") _
                        , "ı", "I"), "i", "İ"))
                    ilko = UCase(Replace(Replace(Range("C1"), "ı", "I"), "i", "İ"))
                    If ilkt = ilko Then
                        For j = 4 To 13
                            sont = UCase(Replace(Replace(Format(Sd.Cells(c.Row, "O"), "mmmm") _
                                , "ı", "I"), "i", "İ"))
                            sono = UCase(Replace(Replace(Cells(1, j), "ı", "I"), "i", "İ"))
                            If sont = sono Then
                                Cells(i, j) = Cells(i, j) + Sd.Cells(c.Row, "Q")
                            End If
                        Next j
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End With
        Cells(i, "C") = "=SUM(D" & i & ":M" & i & ")"
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Mesafe]

Sn. Ömer hocam,
Cevabınızdan ümidi kesince öncelikle tarihleri data sayfasında metne çevirip daha sonra da ÇOKETOPLA ile bir çözüm yapmıştım. Şimdi bunların hepsini silip sizin kodlarınızı uyguladım. Harika oldu elinize emeğinize sağlık.

Çok teşekkürler

 

[Ömer]

Rica ederim.
Ayrıca kusura bakmayın işlerim nedeniyle cevap biraz geçikti.