Formüllü sayfaları makroya çevirmek

I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Korhan Ayhan' Alıntı:
Ek olarak "C SÜTUNUNA GÖRE" sayfası için aşağıdaki kod ile excelin kendi özet tablosunu otomatik oluşturup kullanabilirsiniz.

Benim bilgisayarımda arada hata verdi. Ama dosyayı kaydedip tekrar çalıştırdığımda düzeliyor. Ya da dosyayı kapatıp açıp tekrar denediğimde hata vermiyor.

C++: 
Option Explicit

Sub Pivot_Table()
    Dim S1 As Worksheet, Pivot_Data As Range
    Dim Pivot_Cache As PivotCaches
    Dim Pivot_Table As PivotTables, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("C SÜTUNUNA GÖRE")
    
    S1.Range("F:XFD").Clear
    
    Set Pivot_Data = S1.Range("A1").CurrentRegion
    
    On Error Resume Next
    
    Set Pivot_Cache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Pivot_Data). _
                      CreatePivotTable(TableDestination:=S1.Range("F1"), TableName:="Pivot_Table1")
    
    Set Pivot_Table = Pivot_Cache.CreatePivotTable(TableDestination:=S1.Range("A1"), TableName:="Pivot_Table1")
    
    On Error GoTo 0

    With S1.PivotTables("Pivot_Table1")
        .PivotFields("HANGİ DEPO").Orientation = xlRowField
        .PivotFields("HANGİ DEPO").Position = 1
        .AddDataField ActiveSheet.PivotTables("Pivot_Table1").PivotFields("ADETLER"), "Sum of ADETLER", xlSum
        .PivotFields("ÜRÜN KODU").Orientation = xlColumnField
        .PivotFields("ÜRÜN KODU").Position = 1
    End With
    
    S1.Range("F1").CurrentRegion.Offset(1).Copy
    S1.Range("F1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    S1.Range("F1") = "ÜRÜN KODU"
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlToRight)).Font.Bold = True
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlDown)).Font.Bold = True
    S1.Range(S1.Cells(S1.Rows.Count, "F").End(3), S1.Cells(S1.Rows.Count, "F").End(3).End(xlToRight)).Font.Bold = True
    S1.Range(S1.Cells(2, S1.Columns.Count).End(1), S1.Cells(2, S1.Columns.Count).End(1).End(xlDown)).Font.Bold = True
    S1.Range("A1").Select
    
    S1.Columns.AutoFit
    
    Set S1 = Nothing
    Set Pivot_Data = Nothing
    Set Pivot_Cache = Nothing
    Set Pivot_Table = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Uzmanım gayet güzel çalışıyor, emeklerinize sağlık.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu da Dictionary ile alternatif olsun. Forumun arşivinde olması açısından paylaşıyorum. Veri miktarı artarsa hata verebilir. Bu durumda remi (Ram) yüksek bir bilgisayarda denemek daha uygun olacaktır.

C++: 
Option Explicit

Sub Pivot_Table()
    Dim S1 As Worksheet, Veri As Variant, Son As Long
    Dim X As Long, Y As Integer, Zaman As Double
    Dim Dizi As Object, Aranan As String, Say As Long
    
    Application.ScreenUpdating = False
    
    Zaman = Timer
    
    Set S1 = Sheets("C SÜTUNUNA GÖRE")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    Veri = S1.Range("A2:C" & Son).Value
    
    S1.Range("F:XFD").Clear
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then Dizi.Item(Veri(X, 1)) = 1
    Next
    
    If Dizi.Count > 16378 Then
        Application.ScreenUpdating = True
        MsgBox "Verilerinizi raporlayabilmek için mevcut excel sürümünüzün sütunları yetersiz kalmaktadır." & vbCr & _
               "Daha az veri ile kodları yeniden çalıştırmayı deneyiniz!", vbCritical
        Set Dizi = Nothing
        Exit Sub
    End If
    
    S1.Range("G1").Resize(1, Dizi.Count) = Dizi.Keys
        
    ReDim Liste(1 To UBound(Veri), 1 To Dizi.Count + 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 3) <> "" Then
            If Not Dizi.Exists(Veri(X, 3)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 3), Say
                Liste(Say, 1) = Veri(X, 3)
                Y = WorksheetFunction.Match(Veri(X, 1), Dizi.Keys, 0) + 1
                Liste(Say, Y) = Veri(X, 2)
            Else
                Y = WorksheetFunction.Match(Veri(X, 1), Dizi.Keys, 0) + 1
                Liste(Dizi.Item(Veri(X, 3)), Y) = Liste(Dizi.Item(Veri(X, 3)), Y) + Veri(X, 2)
            End If
        End If
    Next
    
    S1.Range("F1") = "ÜRÜN KODU"
    S1.Range("F2").Resize(Say, UBound(Liste, 2)) = Liste
    S1.Range("F2").Resize(UBound(Liste, 1), UBound(Liste, 2)).Sort Range("F2"), xlAscending
    S1.Cells(S1.Rows.Count, 6).End(3)(2, 1) = "TOPLAM"
    S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)) = "=SUM(G2:G" & S1.Cells(S1.Rows.Count, 6).End(3)(0, 1).Row & ")"
    S1.Cells(1, S1.Columns.Count).End(1)(1, 2) = "TOPLAM"
    S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1) = "=SUM(G2:" & S1.Cells(1, S1.Columns.Count).End(1)(2, 0).Address(0, 0) & ")"
    S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1).Value = S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1).Value
    S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)).Value = S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)).Value
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlToRight)).Font.Bold = True
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlDown)).Font.Bold = True
    S1.Range(S1.Cells(S1.Rows.Count, "F").End(3), S1.Cells(S1.Rows.Count, "F").End(3).End(xlToRight)).Font.Bold = True
    S1.Range(S1.Cells(2, S1.Columns.Count).End(1), S1.Cells(2, S1.Columns.Count).End(1).End(xlDown)).Font.Bold = True
    S1.Columns.AutoFit
            
    Set S1 = Nothing
    Set Dizi = Nothing
    
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub
 
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Korhan Ayhan' Alıntı:
Bu da Dictionary ile alternatif olsun. Forumun arşivinde olması açısından paylaşıyorum. Veri miktarı artarsa hata verebilir. Bu durumda remi (Ram) yüksek bir bilgisayarda denemek daha uygun olacaktır.

C++: 
Option Explicit

Sub Pivot_Table()
    Dim S1 As Worksheet, Veri As Variant, Son As Long
    Dim X As Long, Y As Integer, Zaman As Double
    Dim Dizi As Object, Aranan As String, Say As Long
 
    Application.ScreenUpdating = False
 
    Zaman = Timer
 
    Set S1 = Sheets("C SÜTUNUNA GÖRE")
    Set Dizi = CreateObject("Scripting.Dictionary")
 
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son < 3 Then Son = 3
    Veri = S1.Range("A2:C" & Son).Value
 
    S1.Range("F:XFD").Clear
 
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then Dizi.Item(Veri(X, 1)) = 1
    Next
 
    If Dizi.Count > 16378 Then
        Application.ScreenUpdating = True
        MsgBox "Verilerinizi raporlayabilmek için mevcut excel sürümünüzün sütunları yetersiz kalmaktadır." & vbCr & _
               "Daha az veri ile kodları yeniden çalıştırmayı deneyiniz!", vbCritical
        Set Dizi = Nothing
        Exit Sub
    End If
 
    S1.Range("G1").Resize(1, Dizi.Count) = Dizi.Keys
     
    ReDim Liste(1 To UBound(Veri), 1 To Dizi.Count + 1)
 
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 3) <> "" Then
            If Not Dizi.Exists(Veri(X, 3)) Then
                Say = Say + 1
                Dizi.Add Veri(X, 3), Say
                Liste(Say, 1) = Veri(X, 3)
                Y = WorksheetFunction.Match(Veri(X, 1), Dizi.Keys, 0) + 1
                Liste(Say, Y) = Veri(X, 2)
            Else
                Y = WorksheetFunction.Match(Veri(X, 1), Dizi.Keys, 0) + 1
                Liste(Dizi.Item(Veri(X, 3)), Y) = Liste(Dizi.Item(Veri(X, 3)), Y) + Veri(X, 2)
            End If
        End If
    Next
 
    S1.Range("F1") = "ÜRÜN KODU"
    S1.Range("F2").Resize(Say, UBound(Liste, 2)) = Liste
    S1.Range("F2").Resize(UBound(Liste, 1), UBound(Liste, 2)).Sort Range("F2"), xlAscending
    S1.Cells(S1.Rows.Count, 6).End(3)(2, 1) = "TOPLAM"
    S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)) = "=SUM(G2:G" & S1.Cells(S1.Rows.Count, 6).End(3)(0, 1).Row & ")"
    S1.Cells(1, S1.Columns.Count).End(1)(1, 2) = "TOPLAM"
    S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1) = "=SUM(G2:" & S1.Cells(1, S1.Columns.Count).End(1)(2, 0).Address(0, 0) & ")"
    S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1).Value = S1.Cells(1, S1.Columns.Count).End(1)(2, 1).Resize(Say, 1).Value
    S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)).Value = S1.Cells(S1.Rows.Count, 6).End(3)(1, 2).Resize(1, UBound(Liste, 2)).Value
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlToRight)).Font.Bold = True
    S1.Range(S1.Range("F1"), S1.Range("F1").End(xlDown)).Font.Bold = True
    S1.Range(S1.Cells(S1.Rows.Count, "F").End(3), S1.Cells(S1.Rows.Count, "F").End(3).End(xlToRight)).Font.Bold = True
    S1.Range(S1.Cells(2, S1.Columns.Count).End(1), S1.Cells(2, S1.Columns.Count).End(1).End(xlDown)).Font.Bold = True
    S1.Columns.AutoFit
         
    Set S1 = Nothing
    Set Dizi = Nothing
 
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub
Genişletmek için tıkla ...
Sayın Korhan Ayhan uzmanım, son kodlarınız dahil hepsi gayet güzel çalışıyor. Hiçbir sorun yok. Elinize emeğinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst