Dizinde kriter sayısını artırmak?

[ikikan]

Sub Topla()
Dim S1 As Worksheet, Dizim(), Veri(), Kriter As Variant
Dim x As Long, Satir As Long, Zaman As Double, Bakiye, Bakiye2 As Double

Zaman = Timer

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set S1 = Sheets("ASayfa")

Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row

S1.Range("M11:M" & Satir + 30).ClearContents
Veri = S1.Range("A11" & Satir).Value

Kriter = S1.Range("D1").Value
Kriter =S1.Range("A99" ).Value
Bakiye = 0

ReDim Dizim(1 To UBound(Veri, 1), 1 To 16)

For x = 1 To UBound(Veri, 1)
ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 16)
If Veri(x, 1) = Kriter Then
Dizim(x, 1) = Bakiye + Veri(x, 11) - Veri(x, 12)
Bakiye = Dizim(x, 1)

End If
Next

S1.Range("M11:M" & UBound(Dizim) + 10) = Dizim
Sheets("PCari").Range("A11" & UBound(Dizim) + 10) = Dizim

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With

Set S1 = Nothing

'MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub

Korhan Beyin 2016 yılında yayınladığı bu koda ilave olarak "Kriter" sayısı artarsa örnek 8 kriterli bir durum olursa "Kriter =S1.Range("A99" ).Value" satrında bulunana hücrelerin içine bakarak işlem yapması istenilirse ne gibi bir ekleme yapılmalı dizin komutuna? şimdiden teşekkürler arkadaşlar.

 

[ikikan]

Nasıl bir açmazdır sütunların sayısını gösteremiyorum... konuyu biliyorum bildiğim halde yapamıyorum ya arkadaş....

 

[Korhan Ayhan]

Kriter bölümünü de döngüye alıp deneyiniz.

For Y = 0 To Ubound(Kriter, 2)
'Sorgularınızı buraya yazınız...
Next

 

[ikikan]

Kriter bölümünü de döngüye alıp deneyiniz.

For Y = 0 To Ubound(Kriter, 2)
'Sorgularınızı buraya yazınız...
Next

Ben bir hata yapıyorum Korhan Bey; Kriter sorgusunu ayrımı yapmam lazım? yoksa veri döngüsünün içindemi?

 

[ikikan]

Denedim sütunları görmüyor ....

    ReDim Dizim1(1 To UBound(Kriter, 2), 1 To 1)
    
    For y = 1 To UBound(Kriter, 2)
    ReDim Preserve Dizim1(1 To UBound(Kriter, 1), 1 To 1)
    Dizim1(y, 1) = Kriter(y, 1)
    Next

 

[ikikan]

Kriter bölümünü de döngüye alıp deneyiniz.

For Y = 0 To Ubound(Kriter, 2)
'Sorgularınızı buraya yazınız...
Next

Yanlış olan nedir Korhan Bey benim aklım durdu..

    ReDim Dizim(1 To UBound(Veri, 1), 1 To 1)
       
    For x = 1 To UBound(Veri, 1)
        For y = 0 To UBound(Kriter, 2)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 1)
        
        If Veri(x, 1) = Kriter(1, y) Then
            Dizim(x, 1) = Bakiye + Veri(x, 11) - Veri(x, 12)
            Bakiye = Dizim(x, 1)
            
        End If
    Next
    Next

 

[Korhan Ayhan]

Örnek dosya üzerinden sorarsanız daha net cevaplar alabilirsiniz.

 

[ikikan]

Örnek dosya üzerinden sorarsanız daha net cevaplar alabilirsiniz.

Asıl sorun bendeymiş mantığı yanlış kurmuşum düzenliyorum...
1. etap bu daha doğru olanları evet yanlış olanları hayır yapmam gerekiyor....

For y = 1 To UBound(KRT)
For x = 1 To UBound(VR, 1)
ReDim Preserve Dizim(1 To UBound(VR, 1), 1 To y)

If VR(x, y) = KRT Then
Dizim(x, y) = Bakiye + (VR(x, 11) - VR(x, 12))
Bakiye = Dizim(x, y)
End If
Next x
KTP.Range("A10" & SonSatir).AutoFilter y, KRT
Next y

Az kaldı Korhan Bey size de soracağım sorular olacak dosyayı düzenleyip döneceğim

Örnek Dosya sizinle beraber yorumladığımız konuda ;
http://www.excel.web.tr/f48/altalta-toplayarak-ilerleme-t158556.html

 

[ikikan]

Asıl sorun bendeymiş mantığı yanlış kurmuşum düzenliyorum...
1. etap bu daha doğru olanları evet yanlış olanları hayır yapmam gerekiyor....

Az kaldı Korhan Bey size de soracağım sorular olacak dosyayı düzenleyip döneceğim

Örnek Dosya sizinle beraber yorumladığımız konuda ;
http://www.excel.web.tr/f48/altalta-toplayarak-ilerleme-t158556.html

Örnek dosya ektedir.

 

[ikikan]

Korhan Beyin Düzenlediği koda ek olarak birkaç ekleme yaptım.
Süzülen veriye göre başlıkları alıp toplama işlemi yapıyor fakat kırmızı ile işaretlediğim kodu kısaltmak istiyorum dizi içine almayı denedim beceremedim yardımcı olacak arkadaşlara şimdiden teşekkürler.

Sub ToplaBakiye3()
    Dim KTP As Worksheet, Zaman As Double
    Dim y, x, e, r, k, Bakiye, SSA, SSU, Say, Sayac As Long
    Dim Dizim(), Kriter(), VR(), KT(), z(), a(), b() As Variant
    Dim KR(), Birles() As String
    Dim TRH1, TRH2 As Date

    Zaman = Timer
    
    Set KTP = Sheets("ASayfa")


    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        'Application.Volatile
    End With
    
    SSA = KTP.Cells(KTP.Rows.Count, 1).End(xlUp).Row
    SSU = KTP.Cells(10, Columns.Count).End(xlToLeft).Column
            
    KTP.Range("M11:M" & SSA + 30).ClearContents
    VR = KTP.Range("A11:P" & SSA).Value
                    
ReDim KR(KTP.AutoFilter.Filters.Count)
Say = 1
For k = 1 To KTP.AutoFilter.Filters.Count 'Step 1
    'If KTP.AutoFilter.Filters(k).On Then
     KR(Say) = KTP.Cells(9, k) 'Replace(KTP.AutoFilter.Filters(k).Criteria1, "=", "", 1)
     Say = Say + 1
    'End If
Next k
  
                    TRH1 = KTP.[D5]
                    TRH2 = KTP.[E5]
     
    On Error Resume Next
    KTP.ShowAllData
    On Error GoTo 0

ReDim a(UBound(KR))
ReDim z(UBound(VR))

ReDim Dizim(1 To UBound(VR, 1), 1 To UBound(KR))

For y = 1 To UBound(KR, 1)
Bakiye = 0
    If Not KR(y) = "" Then
    For x = 1 To UBound(VR, 1)
        ReDim Preserve Dizim(1 To UBound(VR, 1), 1 To UBound(KR, 1))
        On Error Resume Next
          
            For r = 1 To y
                a(r) = VR(x, r) = KR(r)
            Next r
[COLOR="Red"]z(1) = a(1)
z(2) = a(1) And a(2)
z(3) = a(1) And a(2) And a(3)
z(4) = a(1) And a(2) And a(3) And a(4)
z(5) = a(1) And a(2) And a(3) And a(4) And a(5)
z(6) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6)
z(7) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6) And a(7)
z(8) = a(1) And a(2) And a(3) And a(4) And a(5) And a(6) And a(7) And a(8)
[/COLOR]
        If z(y) Then
        Dizim(x, 1) = Bakiye + (VR(x, 11) - VR(x, 12))
        Bakiye = Dizim(x, 1)
        End If

Next x
End If
Next y

KTP.Range("M11:M" & UBound(Dizim) + 10) = Dizim

For y = 1 To UBound(KR, 1)
  If Not KR(y) = "" Then: KTP.Range("A10:P" & SSA).AutoFilter y, KR(y)
Next y

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
KTP.Cells(1, 1) = "Sure:" & Format(Timer - Zaman, "0.00000")
Set KTP = Nothing
End Sub