Makro'yu Sadeleştirme (Kısaltma)

[1Al2Ver]

Merhaba,

Aşağıdaki kod daha kısa nasıl yazılabilir ?

Teşekkür ederim.

Sub ÜyeAidatListesi()

    On Error Resume Next
    Dim i As Long
    Sheets("ÜYE_AİDAT_LİSTESİ").Select
    Dim S1 As Worksheet
    Set S1 = Sheets("ÜYE_AİDAT_LİSTESİ")
    
    Range("D3:O" & Rows.Count).ClearContents
    
    S1.Unprotect "12345"
    
    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
    
        Cells(i, "D") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=D2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "E") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=E2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "F") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=F2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "G") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=G2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "H") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=H2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "I") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=I2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "J") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=J2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "K") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=K2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "L") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=L2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "M") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=M2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "N") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=N2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        Cells(i, "O") = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=O2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
        
    Next i
    
    S1.Protect "12345"
    
End Sub

 

[alicimri]

Deneeyemedim.

Sub ÜyeAidatListesi()
    On Error Resume Next
    Dim i As Long
    Sheets("ÜYE_AİDAT_LİSTESİ").Select
    Dim S1 As Worksheet
    Set S1 = Sheets("ÜYE_AİDAT_LİSTESİ")
    Range("D3:O" & Rows.Count).ClearContents
    S1.Unprotect "12345"
    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
    For say = 4 To 15
        Cells(i, say) = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
            "*(Aidat_Raporu!G2:G5000=" & Replace(Cells(2, say).Address, "$", "") & ")*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
          Next
    Next i
    S1.Protect "12345"
End Sub

 

[alicimri]

Hata yapmışım yukardaki kodları düzeitim.

 

[alicimri]

tekrar düzelttim.

 

[halit3]

Alternatif kod:

Sub ÜyeAidatListesi()

    On Error Resume Next
    Dim i As Long
    Sheets("ÜYE_AİDAT_LİSTESİ").Select
    Dim S1 As Worksheet
    Set S1 = Sheets("ÜYE_AİDAT_LİSTESİ")
    
    Range("D3:O" & Rows.Count).ClearContents
    
    S1.Unprotect "12345"

    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
    For j = 4 To 15
    [COLOR="Red"]sut [/COLOR]= Split(Cells(1, j)[COLOR="Red"].address[/COLOR], "$")(1)
    Cells(i, [COLOR="red"]j[/COLOR]) = Evaluate("=SUMPRODUCT((Aidat_Raporu!D2:D5000=" & Cells(i, "B").Address() & ")" & _
    "*(Aidat_Raporu!G2:G5000=[COLOR="red"]" & sut & "[/COLOR]2)*(Aidat_Raporu!J2:J5000=D1)*(Aidat_Raporu!F2:F5000))")
    Next j
    Next i
    
    S1.Protect "12345"
    
End Sub

 

[alicimri]

Sn Halit3 herhalde benim gibi acele etmişsiniz.

 sut = Split(Cells(1, j).address, "$")(1)

 

[halit3]

Evet kod hücre adresi olması gerekirken hücre değeri olmuş.

.address

 

[1Al2Ver]

Sayın alicimri merhaba,

Kod sorunsuz çalışıyor,

İlginiz ve çözüm için teşekkür ederim,

Saygılarımla.

 

[1Al2Ver]

Sayın halit3 merhaba,

Alternatif çözüm ve ilginiz için teşekkür ederim,

Saygılarımla.