Şartlı Çarpma ve Bölme işlemi

[usta07]

Şartlı Çarpma ve Bölme işlemi
Çarpma işlemi:
EĞER B Sutundaki değer = "Plan" ise F=E*G ; H=E*I ; J=E*K şeklinde devam ediyor
Bölme İşlemi:
EĞER B Sutundaki değer = "Past" yada "Real" ise G=F/E ; I=H/E ; K=J/E ; M=L/E şeklinde devam ediyor

Formüller ile çözüm data çok büyük olduğundan biraz kasıyor VBA ile çözüm arıyorum kod konusunda yardımcı olacak arkadaşlarıma şimdiden teşekkür ederim. örnek dosya ektedir.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub MAKRO_İLE_HESAPLAMA()
    Dim X As Long
    
    Application.ScreenUpdating = False
    
    For X = 2 To Range("A65536").End(3).Row
        If Cells(X, "B") = "Plan" Then
            Cells(X, "F") = Cells(X, "E") * Cells(X, "G")
            Cells(X, "H") = Cells(X, "E") * Cells(X, "I")
            Cells(X, "J") = Cells(X, "E") * Cells(X, "K")
            'Bu şekilde istediğiniz kadar satır ekleyebilirsiniz.
        
        ElseIf Cells(X, "B") = "Past" Or Cells(X, "B") = "Real" Then
            
            'Sıfıra bölünme hatası almamak için basit bir if sorgusu kurup hücrelerdeki değerleri sorguluyoruz.
            If Cells(X, "E") = 0 Then
                Cells(X, "G") = ""
            Else
                Cells(X, "G") = Cells(X, "F") / Cells(X, "E")
            End If
            
            If Cells(X, "E") = 0 Then
                Cells(X, "I") = ""
            Else
                Cells(X, "I") = Cells(X, "H") / Cells(X, "E")
            End If
            
            If Cells(X, "E") = 0 Then
                Cells(X, "K") = ""
            Else
                Cells(X, "K") = Cells(X, "J") / Cells(X, "E")
            End If
            
            If Cells(X, "E") = 0 Then
                Cells(X, "M") = ""
            Else
                Cells(X, "M") = Cells(X, "L") / Cells(X, "E")
            End If
            
            'Bu şekilde istediğiniz kadar satır ekleyebilirsiniz.
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Hesaplama işlemi tamamlanmıştır.", vbInformation
End Sub

 

[usta07]

Sayın Korhan AYHAN,
Çok Teşekkür ederim. Allah razı olsun. Hakkınızı helal edin iyiki varsınız.