Çokluetopla fonksiyonuna benzer makro

[ergunarat]

Sanırım oldu

 

[Korhan Ayhan]

Merhaba,

Örneğinizi inceledim.

"6 nolu kasacının 1 adetlik fiş sayısı 4 adettir" bilgisine nasıl ulaşacağız.

 

[ergunarat]

Koray Bey;
ordaki rakamlar afaki yazdım. Amacım çokluesay fonksiyonunu kullanmadan daha hızlı olabilecek bir makro.

 

[Korhan Ayhan]

Merhaba,

Anladım. Fakat bizler sizlere cevap verirken eklediğiniz örnek dosyalardaki verileri inceleyip çözüm üretip doğru sonuç ürettiğini test ettikten sonra foruma yazıyoruz. Sizin afaki veri işlediğinizi sorunuzu okuyan bizlerin nasıl anlamasını bekliyorsunuz. En azından dosyamdaki veriler örnektir ve örnek veriye göre olması gereken sonuç budur diyerek bizleri doğru yönlendirmelisiniz.

Eğer sorunuzu bahsettiğim şekilde sorsaydınız bu mesaj yerine size cevap yazmış olacaktım. Konular bu şekilde gereksiz mesajlarla dahada karmaşık hale geliyor.

Lütfen bu konuya sonraki başlıklarınızda dikkat ediniz.

Gelelim sorunuzun cevabına;

Bu tarz verilerinizi en hızlı şekilde özet tablo kullanarak raporlayabilirsiniz.
Veri menüsünden özet tablo seçeneğini inceleyin. Ya da aşağıdaki linkten nasıl yapıldığını inceleyin.

Özet Tablo Hazırlamak (Resimli Anlatım)

Yok ben illaki makro ile çözüm istiyorum diyorsanız aşağıdaki kodu deneyin.

Sub ÖZET_RAPOR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Y As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Fiş Raporu")
    Set S2 = Sheets("Sonuç")
    
    S2.Select
    S2.Range("C1:" & Cells(Rows.Count, Columns.Count).Address(0, 0)).ClearContents
    
    S1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("F1"), Unique:=True
    S1.Range("F2:F" & S1.Cells(Rows.Count, "F").End(3).Row).Sort S1.Range("F2"), xlAscending
    S1.Range("F2:F" & S1.Cells(Rows.Count, "F").End(3).Row).Copy
    S2.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Range("A1").Select
    
    For X = 3 To S2.Cells(Rows.Count, 1).End(3).Row
        If S2.Cells(X, 1) <> "" Then
            For Y = 3 To S2.Cells(1, Columns.Count).End(1).Column
                S1.Range("A1:D" & Rows.Count).AutoFilter Field:=1, Criteria1:=S2.Cells(X, 1)
                S1.Range("A1:D" & Rows.Count).AutoFilter Field:=2, Criteria1:=S2.Cells(1, Y)
                S1.Range("A1:D" & Rows.Count).AutoFilter Field:=3, Criteria1:=S2.Cells(X, 2)
                S2.Cells(X, Y) = WorksheetFunction.Subtotal(3, S1.Range("A2:A1048576"))
            Next
        End If
    Next
    
    S1.Range("A1").AutoFilter
    S1.Range("F:F").ClearContents
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub