macro ile yüzdelerini bulmak

[asterix1234]

Merhaba Arkadaşlar,

Ek teki örnekte Transay Masraf adlı sayfada XXXX servisini kullanan personelin (departmanlara göre) % lerini bulmak (örnekteki Sarı Satırlar)ve XXX servis ücretinin % kaçını temsil ettiğini bulmak (örnekteki mavi satırlar)

Örnek: (B5 hücresinde % ile belirtilen her satırda yapılacak) C5:R5 arsında
her departmanın temsil eden personelin % bulmak
C5 yazdığım formül :EĞER(C3>0;(C3/TOPLA($C$3:$R$3)*100);"0")
C6 için ise; EĞER(C5>0;$S$3*C5/100;" ")

bunları tüm ilgili satırlara nasıl kod ile yaptırırız ? kodları F2 ile macroya aldırıyorum ama neticede yine formül ve ağır çalışıyor..

 

[asterix1234]

korhan bey teşekkür ederim..

konuyu kapatıyorum. sorunun cevabını içeren kodlar ektedir.

Option Explicit

Sub TOPLA_AKTAR()
Dim S1 As Worksheet, S2 As Worksheet
Dim X As Long, Y As Long
Dim BUL As Range
Dim ADRES As String
Set S1 = Sheets("Bilgiler")
Set S2 = Sheets("Transay Masraf")

S2.Range("C3:R" & S2.[A65536].End(3).Row + 3).ClearContents

For X = 3 To S2.[A65536].End(3).Row Step 4
If S2.Cells(X, "S") > 0 Then
Set BUL = S1.[GY:GY].Find(S2.Cells(X, 1))
If Not BUL Is Nothing Then
ADRES = BUL.Address
Do
S2.Cells(X, "R") = Evaluate("=SUMPRODUCT((Bilgiler!GY2:GY5000=""" & S2.Cells(X, "A") & """)*(Bilgiler!A2:A5000=""" & S2.Cells(2, "R") & """))")

For Y = 3 To 17
If Trim(S1.Cells(BUL.Row, "K")) = Trim(S2.Cells(2, Y)) Then
S2.Cells(X, Y) = S2.Cells(X, Y) + 1
End If
Next

With S2.Range("C" & X + 2 & ":R" & X + 2)
.Formula = "=IF(C" & X & ">0,(C" & X & "/SUM($C$" & X & ":$R$" & X & ")*100),0)"
.Value = .Value
End With
With S2.Range("C" & X + 3 & ":R" & X + 3)
.Formula = "=IF(C" & X + 2 & ">0,$S$" & X & "*C" & X + 2 & "/100,"""")"
.Value = .Value
End With

Set BUL = S1.[GY:GY].FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES

End If
End If
Next
Set BUL = Nothing
Set S1 = Nothing
Set S2 = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub