hesap makrosu

[cihanal]

Ekteki dosyadaki hazırladığım tablodaki değerleri makro ile hesaplamak istiyorum. Yardımlarınızı rica ederim.

 

[cihanal]

düzeltme

Özür dilerim. Dosya eksik olmuş. Ekte doğrusu var.

 

[cihanal]

lütfen

lütfen bir çözüm bekliyorum.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Bul As Range, Adres As String
    Dim Toplam As Double, Say As Integer
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    
    S2.Select
    
    [A2:D65536].ClearContents
        
    S1.Columns("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
    
    For X = 2 To S2.[A65536].End(3).Row
        If S2.Cells(X, 1) <> "" Then
            Say = 0: Toplam = 0
            Set Bul = S1.[D:D].Find(S2.Cells(X, 1))
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
            If Mid(UCase(S1.Cells(Bul.Row, 1)), 1, 1) = "A" Or Mid(UCase(S1.Cells(Bul.Row, 1)), 1, 1) = "B" Then
            Toplam = Toplam + (S1.Cells(Bul.Row, 2) * S1.Cells(Bul.Row, 3) * 1000)
            ElseIf Mid(UCase(S1.Cells(Bul.Row, 1)), 1, 1) = "C" Or Mid(UCase(S1.Cells(Bul.Row, 1)), 1, 1) = "D" Then
            Toplam = Toplam + (S1.Cells(Bul.Row, 2) * S1.Cells(Bul.Row, 3) * 10)
            End If
            Say = Say + 1
            Set Bul = S1.[D:D].FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            S2.Cells(X, 2) = Say
            S2.Cells(X, 3) = WorksheetFunction.SumIf(S1.[D:D], S2.Cells(X, 1), S1.[B:B])
            S2.Cells(X, 4) = Toplam
            End If
        End If
    Next
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[cihanal]

Teşekkür

Korhan Bey, çok teşekkür ederim. Çok yardımcı oldunuz.