• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Formüllü sayfaları makroya çevirmek

  • Konbuyu başlatan Konbuyu başlatan izcik
  • Başlangıç tarihi Başlangıç tarihi
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Merhaba

ornek1 adlı dosyada, formüllerin bulunduğu iki adet sayfa var. Bu iki saydadaki formüllerin makroya çevirilmesini rica ederim.

Sebebi de şudur; formüller güzel fakat, satırlar 3000-4000 satır olduğunda, sadece F sütununun işlemi yapması bile yarım saatten fazla sürüyor.

Ayrıca örnek2 dosyasını da numune olarak gönderiyorum. Bu dosyadaki makroları sayın Korhan Ayhan uzmanım yapmıştı.

Örnek1’deki sayfalar da, örnek 2 gibi olursa çok iyi olur. Teşekkürler.


örnek1 (yapılması gereken)

ornek1.xlsx dosyasını indir - download

ornek1.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc www.dosya.tc



Örnek2 (Korhan Ayhan uzmanımın daha önce yaptığı numune)

ornek2.xlsm dosyasını indir - download

ornek2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
 
Uzmanım emeğinize sağlık, merak ve hevesle hemen indirdim. Neticeyi arz edeceğim.
 
Uzmanım bir minik soru arz edeceğim;
Örnek; ben fıormüllerdeki 2000 sayılarını (gerektiğinde) 6500 olarak değiştiriyordum. Makrolu dosyamız da 2000 satır için mi geçerlidir yoksa sayfanın sonuna kadar mı geçerlidir?
 
Deneme yaparak sonucu görebilirsiniz. ;)
 
Sayın Uzmanım konu hazır tazeyken size bir dosya daha arz edeyim. :)


Sütunları ve satırları tersine aktarma.

(Fakat B’den G’ye kadar olan sütunlar değişebilir)
Bazen B’den E’ye kadar olabilir,
Bazen B’den J’ye kadar olabilir.

Saygılar :)

ornek.xlsx dosyasını indir - download

ornek.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
 
Aradığınız işlem kopyala-özel yapıştır-işlemi tersine çevir özelliğidir.

Makro kaydet yöntemi ile elde ettiğim kodları biraz düzenledim.

C++: 
Option Explicit

Sub Transpose_Aktar()
    Application.ScreenUpdating = False
    
    Range("K:XFD").Clear
    Range("A1").CurrentRegion.Copy
    Range("K1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Application.CutCopyMode = False
    Range("A1").Select
    Columns.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Aradığınız işlem kopyala-özel yapıştır-işlemi tersine çevir özelliğidir.

Makro kaydet yöntemi ile elde ettiğim kodları biraz düzenledim.

C++: 
Option Explicit

Sub Transpose_Aktar()
    Application.ScreenUpdating = False
  
    Range("K:XFD").Clear
    Range("A1").CurrentRegion.Copy
    Range("K1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Application.CutCopyMode = False
    Range("A1").Select
    Columns.AutoFit
  
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Uzmanım sağ olunuz. Hemen inceliyorum. :)
 
Korhan Ayhan' Alıntı:
Aradığınız işlem kopyala-özel yapıştır-işlemi tersine çevir özelliğidir.

Makro kaydet yöntemi ile elde ettiğim kodları biraz düzenledim.

C++: 
Option Explicit

Sub Transpose_Aktar()
    Application.ScreenUpdating = False
   
    Range("K:XFD").Clear
    Range("A1").CurrentRegion.Copy
    Range("K1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Application.CutCopyMode = False
    Range("A1").Select
    Columns.AutoFit
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Bravo ??????????????
 
Bu da alternatif olsun.

Bir önceki kod kopyala-yapıştır metodu ile işlemi yapıyor. Aşağıda ki kod ise VBA komutları ile bu işlemi yapıyor.

C++: 
Option Explicit

Sub Transpose_Aktar()
    Dim Alan As Range

    Application.ScreenUpdating = False
    
    Set Alan = Range("A1").CurrentRegion
    
    Range("K:XFD").Clear
    Range("K1").Resize(Alan.Columns.Count, Alan.Rows.Count).Value = Application.Transpose(Alan.Value)
    Columns.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Bu da alternatif olsun.

Bir önceki kod kopyala-yapıştır metodu ile işlemi yapıyor. Aşağıda ki kod ise VBA komutları ile bu işlemi yapıyor.

C++: 
Option Explicit

Sub Transpose_Aktar()
    Dim Alan As Range

    Application.ScreenUpdating = False
   
    Set Alan = Range("A1").CurrentRegion
   
    Range("K:XFD").Clear
    Range("K1").Resize(Alan.Columns.Count, Alan.Rows.Count).Value = Application.Transpose(Alan.Value)
    Columns.AutoFit
   
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Uzmanım varolun; bilgisayar başına geçer geçmez hemen deneyeceğim. ?

Bir de çok küçük başka bir sorum olacak. Aslında şu an da arz edebilirim.

Hani upload sitesine yüklediğiniz dosyada, iki sayfada da düğmeye basınca “Toplam adetler” oluşuyor ya,
Kodlarda nereyi silersek bu adet sütunları iptal olur?
Deneme yanılmayla yapmaya çalıştım, olmadı :)
 
Kırmızı bölümü silerek deneyebilirsiniz.

Sorgu = "Transform Sum([ADETLER]) " & _
"Select [HANGİ DEPO], Sum([ADETLER]) As [TOPLAM ADET] From [C SÜTUNUNA GÖRE$] " & _
"Group By [HANGİ DEPO] Pivot [ÜRÜN KODU]"
Genişletmek için tıkla ...
 
Korhan Ayhan' Alıntı:
Merhaba,

Örnek dosyayı inceleyiniz. Formüllü alanları bilerek silmedim. Böylece sonuçları kontrol edebilirsiniz.

Harici Link (Silinebilir) ; https://dosyam.org/1OqD/Örnek_1_Pivot.xlsm
Genişletmek için tıkla ...
Sayın Korhan Ayhan uzmanım merhaba,

İki küçük hata ile karşılaştım ve arz etmek istedim.

Birinci sayfada düğmeye bastığımızda, oluşmaması gereken P sütunu oluşuyor; P1 hücresinde “küçük-büyük” işaretleri oluşuyor ve altında oluşmaması gereken bir boş satır oluşuyor. (N2-U2 arası)

İkinci sayfada ise düğmeye bastığımızda hata veriyor. Rica etsem düzeltebilir misiniz :)

Arz ederim

Saygılar.


https://s6.dosya.tc/server3/5w0icj/uzmanima_ornek.xlsm.html
 
"A SÜTUNUNA GÖRE" isimli sayfanız için sorgu satırını aşağıdaki gibi değiştirip kullanabilirsiniz.

C++: 
    Sorgu = "Transform Sum([ADETLER]) " & _
            "Select [ÜRÜN KODU], Sum([ADETLER]) As [TOPLAM ADET] From [A SÜTUNUNA GÖRE$] Where Not IsNull([ÜRÜN KODU]) " & _
            "Group By [ÜRÜN KODU] Pivot [HANGİ DEPO]"



ADO ile 255 sütunluk veri derleyebilirsiniz. Daha fazla sütunluk veri varsa hata verecektir. Sizin "C SÜTUNUNA GÖRE" isimli sayfanızda 899 adet benzersiz ürün kodu bulunuyor.
 
Korhan Ayhan' Alıntı:
"A SÜTUNUNA GÖRE" isimli sayfanız için sorgu satırını aşağıdaki gibi değiştirip kullanabilirsiniz.

C++: 
    Sorgu = "Transform Sum([ADETLER]) " & _
            "Select [ÜRÜN KODU], Sum([ADETLER]) As [TOPLAM ADET] From [A SÜTUNUNA GÖRE$] Where Not IsNull([ÜRÜN KODU]) " & _
            "Group By [ÜRÜN KODU] Pivot [HANGİ DEPO]"



ADO ile 255 sütunluk veri derleyebilirsiniz. Daha fazla sütunluk veri varsa hata verecektir. Sizin "C SÜTUNUNA GÖRE" isimli sayfanızda 899 adet benzersiz ürün kodu bulunuyor.
Genişletmek için tıkla ...
Sayın uzmanım hemen denemeler yapıyorum :)
 
Korhan Ayhan' Alıntı:
"A SÜTUNUNA GÖRE" isimli sayfanız için sorgu satırını aşağıdaki gibi değiştirip kullanabilirsiniz.

C++: 
    Sorgu = "Transform Sum([ADETLER]) " & _
            "Select [ÜRÜN KODU], Sum([ADETLER]) As [TOPLAM ADET] From [A SÜTUNUNA GÖRE$] Where Not IsNull([ÜRÜN KODU]) " & _
            "Group By [ÜRÜN KODU] Pivot [HANGİ DEPO]"



ADO ile 255 sütunluk veri derleyebilirsiniz. Daha fazla sütunluk veri varsa hata verecektir. Sizin "C SÜTUNUNA GÖRE" isimli sayfanızda 899 adet benzersiz ürün kodu bulunuyor.
Genişletmek için tıkla ...


Sayın uzmanım denemelerimi yaptım; hemen arz edeyim.

“A SÜTUNUNA GÖRE” sayfasındaki Sorgu satırını verdiğiniz ile değiştirdim, düzeldi.

..

Aynı sorunun (boş satır oluşması ve <> işaretlerinin oluşması) “C SÜTUNUNA GÖRE” sayfasında da olduğunu farkettim.

Size zahmet olmazsa bu sayfanın da (C.S.G.) Sorgu satırını yazar mısınız? :)

Hemen örnek dosya arz ediyorum.

uzmanima_ornek2.xlsm dosyasını indir - download

uzmanima_ornek2.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s5.dosya.tc s5.dosya.tc
 
Deneyiniz.

C++: 
    Sorgu = "Transform Sum([ADETLER]) " & _
            "Select [HANGİ DEPO], Sum([ADETLER]) As [TOPLAM ADET] From [C SÜTUNUNA GÖRE$] Where Not IsNull([HANGİ DEPO]) " & _
            "Group By [HANGİ DEPO] Pivot [ÜRÜN KODU]"
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst