Topla çarpım koduna 4. koşulu ekleyebilirmiyiz.

[simtaş]

Forumda bulduğum Topla çarpım Kodunu kendi dosyama uyarladım. Ancak 4.koşulu eklemeye çalıştım yapamadım. Yardımcı olursanız sevinirim.

 

[simtaş]

Yardım edecek yok mu?

 

[JEMOV]

Bende de böyle bir istek var ama yapamıyorum

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Yalnız uygulamış olduğunuz yöntem kod ile TOPLA.ÇARPIM uygulama yöntemi değildir. Verileri döngüye alarak kriterlere uyan verileri toplatmaktır. Konuyla ilgilenenler olabilir düşüncesi ile ek bilgi vermek istedim.

Sub SELEKSİYON()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim HÜCRE As Range
    Dim BUL As Range, ADRES As String
    Dim KRİTER As Range
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    S2.Range("D25:M26").ClearContents
    
    For Each HÜCRE In S2.Range("A25:A26")
        Set BUL = S1.[P11:P65536].Find(HÜCRE.Value)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
    
    If S1.Cells(BUL.Row, 4) = S2.Range("D23") And S1.Cells(BUL.Row, 18) = S2.Range("A23") Then
        For Each KRİTER In S2.Range("D24:E24")
        If KRİTER.Value = S1.Cells(BUL.Row, 3) Then
        S2.Cells(HÜCRE.Row, KRİTER.Column) = S2.Cells(HÜCRE.Row, KRİTER.Column) + S1.Cells(BUL.Row, 8)
        Exit For
        End If
        Next
    
    ElseIf S1.Cells(BUL.Row, 4) = S2.Range("F23") And S1.Cells(BUL.Row, 18) = S2.Range("A23") Then
        For Each KRİTER In S2.Range("F24:G24")
        If KRİTER.Value = S1.Cells(BUL.Row, 3) Then
        S2.Cells(HÜCRE.Row, KRİTER.Column) = S2.Cells(HÜCRE.Row, KRİTER.Column) + S1.Cells(BUL.Row, 8)
        Exit For
        End If
        Next
    
    ElseIf S1.Cells(BUL.Row, 4) = S2.Range("H23") And S1.Cells(BUL.Row, 18) = S2.Range("A23") Then
        For Each KRİTER In S2.Range("H24:I24")
        If KRİTER.Value = S1.Cells(BUL.Row, 3) Then
        S2.Cells(HÜCRE.Row, KRİTER.Column) = S2.Cells(HÜCRE.Row, KRİTER.Column) + S1.Cells(BUL.Row, 8)
        Exit For
        End If
        Next
    
    ElseIf S1.Cells(BUL.Row, 4) = S2.Range("J23") And S1.Cells(BUL.Row, 18) = S2.Range("A23") Then
        For Each KRİTER In S2.Range("J24:K24")
        If KRİTER.Value = S1.Cells(BUL.Row, 3) Then
        S2.Cells(HÜCRE.Row, KRİTER.Column) = S2.Cells(HÜCRE.Row, KRİTER.Column) + S1.Cells(BUL.Row, 8)
        Exit For
        End If
        Next
    
    ElseIf S1.Cells(BUL.Row, 4) = S2.Range("L23") And S1.Cells(BUL.Row, 18) = S2.Range("A23") Then
        For Each KRİTER In S2.Range("L24:M24")
        If KRİTER.Value = S1.Cells(BUL.Row, 3) Then
        S2.Cells(HÜCRE.Row, KRİTER.Column) = S2.Cells(HÜCRE.Row, KRİTER.Column) + S1.Cells(BUL.Row, 8)
        Exit For
        End If
        Next
    
    End If
    
        Set BUL = S1.[P11:P65536].FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    
    Next
    
    Set BUL = Nothing
    
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[simtaş]

Sayın Korhan Ayhan çok teşekkür ederim.