Sorgulama kriterini değiştirilince hatalı sonuçlar veriyor

[asterix1234]

Kimse yok mu ?

F1 F1 Help

 

[Korhan Ayhan]

Selamlar,

Ben firma isminide sorguya eklemiştim. Sizin dediğiniz değere göre firma isminin önemi ortadan kalkıyor. Bu durumda kodu aşağıdaki şekilde değiştirip denermisiniz.

Değişiklik yaptığım kısmı kırmızı renkle belirttim.

Option Explicit
 
 
Sub TOPLA_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Long, Z As Integer
    Dim BUL As Range
    Dim ADRES As String
    Set S1 = Sheets("Bilgiler")
    Set S2 = Sheets("Transay Masraf")
 
    For X = 3 To S2.[A65536].End(3).Row Step 4
    S2.Range("C" & X & ":R" & X).ClearContents
    Next
    For Y = 3 To S2.[A65536].End(3).Row Step 4
    If S2.Cells(Y, "S") > 0 Then
    Set BUL = S1.[GY:GY].Find(S2.Cells(Y, 1))
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    S2.Cells(Y, "R") = Evaluate("=SUMPRODUCT((Bilgiler!GY2:GY5000=""" & S2.Cells(Y, "A") & """)*(Bilgiler!A2:A5000=""" & S2.Cells(2, "R") & """))")
 
    For Z = 3 To 17
[COLOR=red]    If Trim(S1.Cells(BUL.Row, "K")) = Trim(S2.Cells(2, Z)) Then[/COLOR]
    S2.Cells(Y, Z) = S2.Cells(Y, Z) + 1
    End If
    Next
 
    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

 

[janveljan]

Korhan beyin kodlarından faydalanarak, biraz sadeleştirdim.

Sub TOPLA_AKTAR2()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Long, Z As Integer
    Dim BUL As Range
    Dim ADRES As String
    Set S1 = Sheets("Bilgiler")
    Set S2 = Sheets("Transay Masraf")
 
    For X = 3 To 71 Step 4
    S2.Range("C" & X & ":R" & X).ClearContents
    Next
    
    For Y = 3 To 71 Step 4
        If S2.Cells(Y, "S") > 0 Then
        S2.Cells(Y, "R") = Evaluate("=SUMPRODUCT((Bilgiler!GY2:GY5000=""" & S2.Cells(Y, "A") & """)*(Bilgiler!A2:A5000=""" & S2.Cells(2, "R") & """))")
        For Z = 3 To 17
            S2.Cells(Y, Z) = Evaluate("=SUMPRODUCT((Bilgiler!GY2:GY5000=""" & S2.Cells(Y, "A") & """)*(Bilgiler!K2:K5000=""" & S2.Cells(2, Z) & """)*(Bilgiler!A2:A5000<>""" & S2.Cells(2, "R") & """))")
        Next
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Sn. janveljan,

Arkadaşımızın sorunu kodun yavaş çalışmasıydı. Sizin en son yaptınız düzenleme ile kod kısaldı fakat TOPLA.ÇARPIM fonksiyonunu kod içinde sıkça kullanmak yine yavaşlamaya sebep olmaktadır. Bu sorun şu şekilde aşılabilir. Ben satır sayısını 5.000 olarak baz almıştım. Bu değer düşürülerek kodun sizin son önerdiğiniz şekilde hızlı çalışması sağlanabilir.

 

[janveljan]

Sn.Korhan
Biz ilk başta süzme işlemi kullanarak yaptırıyorduk işlemleri bana kalırsa yavaş çalışmasınını temel sebebi o idi, bu haliyle zannediyorum eskisine göre yeteri kadar hızlanmış olacak.

 

[asterix1234]

Arkadaşlar emeklerinize sağlık, gayet hızlı ve pratik oldu, Çook ama çok teşekkürler..

 

[asterix1234]

son bir sıkıntım daha var, bunu da yapabilirsek bu iş bitmiş olacak.

Ö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ışmasını istemiyorum

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

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