Soru Oran Hesaplama Hk.

[Erdogan3434]

Merhabalar,
Bir konuda desteğinizi rica ediyorum. Öncelikle tablomda maksimum SATIR sayısı değişkenlik göstermektedir. İlk 8 kolon makro ile oluşmaktadır. Örnekte görünen son iki kolonu da kodun altına ekleyerek hazırlamaya çalışmaktayım. Kolon açıklamalarını örnek dosyaya yazdım.
Desteğinizi rica ediyorum.
Saygılarımla.

 

[Muzaffer Ali]

Merhaba.
Deneyiniz.

Sub Test()
    Dim Say As Long
    Dim Bak As Long
    Dim ToplamB As Double
    Dim ToplamE As Double
    Say = Cells(Rows.Count, "A").End(xlUp).Row
    ToplamB = WorksheetFunction.Sum(Range("B2:B" & Say - 1))
    ToplamE = WorksheetFunction.Sum(Range("E2:E" & Say - 1))
    
    For Bak = 2 To Say
        Cells(Bak, "I") = Cells(Bak, "B") / ToplamB
        Cells(Bak, "J") = Cells(Bak, "E") / ToplamE
    Next
    Cells(Say, "I") = 1
    Cells(Say, "J") = 1
End Sub

 

[Erdogan3434]

Merhaba.
Deneyiniz.

Sub Test()
    Dim Say As Long
    Dim Bak As Long
    Dim ToplamB As Double
    Dim ToplamE As Double
    Say = Cells(Rows.Count, "A").End(xlUp).Row
    ToplamB = WorksheetFunction.Sum(Range("B2:B" & Say - 1))
    ToplamE = WorksheetFunction.Sum(Range("E2:E" & Say - 1))
   
    For Bak = 2 To Say
        Cells(Bak, "I") = Cells(Bak, "B") / ToplamB
        Cells(Bak, "J") = Cells(Bak, "E") / ToplamE
    Next
    Cells(Say, "I") = 1
    Cells(Say, "J") = 1
End Sub

Hocam öncelikle desteğiniz için teşekkür ederim. Ancak değerler yarı yarıya dönüyor. I ve J kolonunun toplamının %100 olması gerekiyor. Bi de en alt satıra iki tane 0 atıyor.

 

[1Al2Ver]

Merhaba,

İşe karışmak gibi oldu ama, şöyle bir çözüm ile sonuç elde edile bilir !

Cells(Bak, "I") = Cells(Bak, "B") / ToplamB*2
Cells(Bak, "J") = Cells(Bak, "E") / ToplamE*2

 

[Muzaffer Ali]

Bende öyle olmuyor. Dosya ekte inceleyiniz.

 

[Erdogan3434]

Bende öyle olmuyor. Dosya ekte inceleyiniz.

Hocam aslında formül olayını çözmüştüm ama döngü kuramıyordum. Mesajınızı görmeden önce döngüyü aşağıdaki şekilde değiştirerek denedim. Sonuç aldım.

Sub ORANHESAPLA()
Dim Say As Long
Dim Bak As Long
Dim ToplamB As Double
Dim ToplamE As Double
Say = Cells(Rows.Count, "B").End(xlUp).Row
ToplamB = Cells(Cells(Rows.Count, 2).End(3).Row, 2)
ToplamE = Cells(Cells(Rows.Count, 5).End(3).Row, 5)

For Bak = 2 To Say
Cells(Bak, "I") = Cells(Bak, "B") / ToplamB
Cells(Bak, "J") = Cells(Bak, "E") / ToplamE
Next
Cells(Say, "I") = 1
Cells(Say, "J") = 1
End Sub

Desteğiniz için çok teşekkür ederim.
Saygılarımla.

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.

 

[Erdogan3434]

Merhaba,

İşe karışmak gibi oldu ama, şöyle bir çözüm ile sonuç elde edile bilir !

Cells(Bak, "I") = Cells(Bak, "B") / ToplamB*2
Cells(Bak, "J") = Cells(Bak, "E") / ToplamE*2

Asla karışmak olarak yorumlamayın lütfen benim için her fikir daha eğitici oluyor. Desteğiniz için teşekkür ederim.

 

[Korhan Ayhan]

Döngüsüz alternatif...

Option Explicit

Sub Test()
    Dim Son As Long
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    Range("I2:J" & Rows.Count).ClearContents
    
    With Range("I2:I" & Son)
        .Formula = "=B2/B$" & Son
        .Value = .Value
    End With

    With Range("J2:J" & Son)
        .Formula = "=E2/E$" & Son
        .Value = .Value
    End With
End Sub

 

[Erdogan3434]

Döngüsüz alternatif...

Option Explicit

Sub Test()
    Dim Son As Long
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    Range("I2:J" & Rows.Count).ClearContents
   
    With Range("I2:I" & Son)
        .Formula = "=B2/B$" & Son
        .Value = .Value
    End With

    With Range("J2:J" & Son)
        .Formula = "=E2/E$" & Son
        .Value = .Value
    End With
End Sub

Korhan hocam çok teşekkür ederim. Her paylaşımınız daha çok öğrenmemi sağlıyor.