Formülle yazılmış olan dosyayı makroya çevirmek

[m.gur]

Selam forum üyeleri. Ekte sunduğum dosya sayın excelci1 tarafından uyarlandı. Dosya çok ağır çalışıyor, mümkünse burdaki formülleri makroya çevirmek istiyorum beceremedim. Yardımlarınızı bekliyorum. Hayırlı Cumalar.

 

[Huseyinkis]

Selam forum üyeleri. Ekte sunduğum dosya sayın excelci1 tarafından uyarlandı. Dosya çok ağır çalışıyor, mümkünse burdaki formülleri makroya çevirmek istiyorum beceremedim. Yardımlarınızı bekliyorum. Hayırlı Cumalar.

Hiç pvot tabel kullandınızmı ?

Ektedki dosyada pvt table ornekleri mevcut formulsuz işleminizi 5 saniyede hesaplar.

 

[Korhan Ayhan]

Merhaba,

Bende makro ile çözüm istediğiniz için kod hazırlamıştım. Alternatif olarak deneyebilirsiniz.

Tabiki her zaman öncelik excelin yerleşik işlevlerindedir.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim S3 As Worksheet
    Dim S4 As Worksheet
    Dim X, Y, Zaman
    
    Application.ScreenUpdating = False
    
    Zaman = Time
    
    Set S1 = Sheets("ANASAYFA")
    Set S2 = Sheets("makam")
    Set S3 = Sheets("usul")
    Set S4 = Sheets("makam&usul")
    
    S2.Cells.Clear
    S3.Cells.Clear
    S4.Cells.Clear
    
    S1.Range("A1") = "Eserin İlk Dizesi"
    S1.Range("B1") = "Söz Yazarı"
    S1.Range("C1") = "Makam"
    S1.Range("D1") = "Form"
    S1.Range("E1") = "Usûl"
    S1.Range("F1") = "Bestekâr"
    
    S1.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S2.Range("A1"), Unique:=True
    With S2.Range("B2:B" & S2.Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=COUNTIF(" & S1.Name & "!C:C,A2)"
        .Value = .Value
    End With
    
    S2.Range("A2:B" & S2.Cells(Rows.Count, 1).End(3).Row).Sort Key1:=S2.Range("B2"), Order1:=xlDescending
    
    S1.Columns("E:E").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S3.Range("A1"), Unique:=True
    With S3.Range("B2:B" & S3.Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=COUNTIF(" & S1.Name & "!E:E,A2)"
        .Value = .Value
    End With
    
    S3.Range("A2:B" & S3.Cells(Rows.Count, 1).End(3).Row).Sort Key1:=S3.Range("B2"), Order1:=xlDescending
    
    S1.Range("G1") = "ÖZEL_ALAN"
    With S1.Range("G2:G" & S1.Cells(Rows.Count, 1).End(3).Row)
        .Formula = "=C2&E2"
        .Value = .Value
    End With
    
    Application.CutCopyMode = False
    
    S4.Select
        
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "ANASAYFA!A1:G" & S1.Cells(Rows.Count, 1).End(3).Row).CreatePivotTable TableDestination:= _
        Range("A1"), TableName:="Özet Tablo 1", DefaultVersion:=xlPivotTableVersion10
    With ActiveSheet.PivotTables("Özet Tablo 1").PivotFields("Usûl")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("Özet Tablo 1").PivotFields("Makam")
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveSheet.PivotTables("Özet Tablo 1").AddDataField ActiveSheet.PivotTables( _
        "Özet Tablo 1").PivotFields("ÖZEL_ALAN"), "Say ÖZEL_ALAN", xlCount
    
    ActiveSheet.PivotTables("Özet Tablo 1").PivotFields("Makam").AutoSort xlDescending, "Say ÖZEL_ALAN"
    ActiveSheet.PivotTables("Özet Tablo 1").PivotFields("Usûl").AutoSort xlDescending, "Say ÖZEL_ALAN"
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Range("A1").Select
    Application.CutCopyMode = False
    
    With Range("B1:" & Cells(1, Cells(2, Columns.Count).End(1).Column).Address(0, 0))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    
    With Range("B2:" & Cells(2, Cells(2, Columns.Count).End(1).Column).Address(0, 0))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 90
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Range("A1").ClearContents
    
    Range("A2,B1").Font.Bold = True
    Range("A2,B1").Interior.ColorIndex = 6
    Range("A2").ClearContents
    Range("A2") = "USÜL"
    Range("B1") = "MAKAM"
    Range("A2").HorizontalAlignment = xlCenter
    Range("A2").VerticalAlignment = xlCenter
    Range("A1").CurrentRegion.Borders.LineStyle = 1
    Cells(Rows.Count, 1).End(3).EntireRow.Font.Bold = True
    Cells(2, Columns.Count).End(1).EntireColumn.Font.Bold = True
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    
    S1.Range("A1").Formula = "=""Eserin İlk Dizesi :  "" & SUBTOTAL(3,A2:A6556)"
    S1.Range("B1").Formula = "Söz Yazarı :"
    S1.Range("C1").Formula = "=""Makam :  "" & SUBTOTAL(3,C2:C65536)"
    S1.Range("D1").Formula = "Form :"
    S1.Range("E1").Formula = "=""Usûl :  "" & SUBTOTAL(3,E2:E65536)"
    S1.Range("F1").Formula = "Bestekâr :"
    S1.Range("G:G").Clear
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Time - Zaman, "hh:mm:ss"), vbInformation
End Sub

 

[m.gur]

Sayın Huseyinkis ve sayın Korhan Ayhan her ikinizede teşekkür ederim. pivot table hızlı fakat benim isteğime cevap vermiyor. Kodlarla da yine yavaş çalışıyor ve her defasında çalışmadı. Çeşitli varyasyonlar denedim ama beceremedim. Sanırım yine eskisi gibi manuel yapıcam çalışma dosyamı. Tekrar teşekkür ederim. Saygılar.

 

[Korhan Ayhan]

Merhaba,

Ben dosyanızdaki verileri 25.000 satır yaparak denedim ve yaklaşık 4 saniyede işlem tamamlandı.

Sizin yapamadığınız yer neresi?

 

[m.gur]

Selam; nihayet çalıştı ama tam tamına 3 dakika 43 saniyede tamamladı işlemi. 2 defa denedim. Bazende dediğiniz gibi 4-5 saniyede bitiriyor fakat verileri aktarmıyor sadece 2 satır ve 2 sütun olarak aktarıyor.


İlave: Dosya açılmamaya başladı. Ekran görüntüsü aşağıda olduğu gibidir. Bunun anlamı nedir nasıl düzeltebilirim ?

 

[m.gur]

Konu günceldir.

 

[Korhan Ayhan]

Merhaba,

Sizin ilk mesajınızdaki dosyada deneme yapmıştım. Asıl dosyanızda başka problemler olabilir. Denemeden yorum yapmak yanlış olur.

 

[m.gur]

Korhan bey ilk mesajımdada belirttiğim gibi verilerim yaklaşık 21000 satır ve 6 sütundan oluşuyor, gerçekten işlem yapıp sonucu beklemesi çok zor. Peki bazen neden 2 satır ve 2 sütunluk bilgi aktarımı yapar? İlk satırda filtre uyguluyorum onun etkisi varmıdır?

 

[Korhan Ayhan]

Merhaba,

Bir mahsuru yoksa asıl dosyanızı sıkıştırıp eklemeyi deneyin. Yada mail atın bakalım sorun neden kaynaklanıyor.

 

[Korhan Ayhan]

Merhaba,

#3 nolu mesajımdaki kodu güncelledim. Tekrar denermisiniz.

Orjinal dosyanızda benim işyerimdeki bilgisayarda işlem 6 saniye sürüyor.

 

[m.gur]

Evet bu defa oldu benim pc 4 saniyede bitirdi. Çok teşekkür ederim Korhan bey elinize sağlık.