• DİKKAT

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

Makro İle Büyük Excel i Belli Kriterlere Göre Farklı Excellere Aktarma

askm' Alıntı:
Bu bilgileri paylaşmışsınız. Çalışma kitabınızdaki verileri silin. Sadece sutun başlıkları kalsın. Sütulara da farazi bilgiler girin. Ali, Veli, Selim gibi. Amacımız size yardımcı olmak. Ama örnek dosya olmadan uğraşmak istemiyorum. Dilerseniz özelden de yazabilirsiniz ya da mail de atabilirsiniz.
Genişletmek için tıkla ...

bilgiler fake. veri şekli ve bilgiler zaten böyle birşey değil çok farklı. şimdi örnek olsun diye salladım. akşam umarım excel i yükleyebilir yada size mail atarım. aslında yapacağım şey önceki mail de yazan şeyleri copy-paste excel yapıp göndermek başka bir şey değil.
 
Örnek dosya ektedir.
Kodları da aşağıdaki şekilde. Yalnız verileriniz Sayfa1 de olduğunu varsaydım. Ve Sayfa2 isminde yardımcı bir sayfa kullandım.
Kod: 
Sub ASKM_Filtrele()
Dim s1, s2 As Worksheet
Dim SonSat1, SonSat2 As Long
Dim baslangic, bitis As Date
baslangic = Time
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sayfa2")
SonSat2 = s1.Range("A" & Rows.Count).End(xlUp).Row
s1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T1"), Unique:=True

SonSat1 = s1.Range("T" & Rows.Count).End(xlUp).Row

For i = 2 To SonSat1
    Aranan = s1.Cells(i, "T")
    s2.Cells.Clear
    s1.Range("A1:E" & SonSat2).AutoFilter Field:=2, Criteria1:=Aranan
    s1.Range("A:E").Copy
    
    s2.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    s2.Range("A1").PasteSpecial
    Application.DisplayAlerts = False
    s2.Select
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & Aranan & ".xls"  'Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".xls"
        .Close
    End With
    s1.Select
    
Next
s1.Range("A1:E1").AutoFilter
s1.Range("T:T").Clear
s2.Cells.Clear
bitis = Time
MsgBox Format(bitis - baslangic, "hh:mm:ss") & " Sürede İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "ASKM"
End Sub
 

Ekli dosyalar

Kodları sizin istediğiniz şekilde yukarıda revize ettim.
 
askm' Alıntı:
Örnek dosya ektedir.
Kodları da aşağıdaki şekilde. Yalnız verileriniz Sayfa1 de olduğunu varsaydım. Ve Sayfa2 isminde yardımcı bir sayfa kullandım.
Kod: 
Sub ASKM_Filtrele()
Dim s1, s2 As Worksheet
Dim SonSat1, SonSat2 As Long
Dim baslangic, bitis As Date
baslangic = Time
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sayfa2")
SonSat2 = s1.Range("A" & Rows.Count).End(xlUp).Row
s1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T1"), Unique:=True

SonSat1 = s1.Range("T" & Rows.Count).End(xlUp).Row

For i = 2 To SonSat1
    Aranan = s1.Cells(i, "T")
    s2.Cells.Clear
    s1.Range("A1:E" & SonSat2).AutoFilter Field:=2, Criteria1:=Aranan
    s1.Range("A:E").Copy
    
    s2.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    s2.Range("A1").PasteSpecial
    Application.DisplayAlerts = False
    s2.Select
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & Aranan & ".xls"  'Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".xls"
        .Close
    End With
    s1.Select
    
Next
s1.Range("A1:E1").AutoFilter
s1.Range("T:T").Clear
s2.Cells.Clear
bitis = Time
MsgBox Format(bitis - baslangic, "hh:mm:ss") & " Sürede İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "ASKM"
End Sub
Genişletmek için tıkla ...



tablom ilk satırı sütun isimleri olan A1-N138902 arasında. sizin kodları bu A-N arasına uygurmaya çalıştım. ama hata aldım. kriter A sütununa göre ayıracak.

aldığım hata

"subscript out of range" debug bakınca da Set s1 = Worksheets("Sayfa1") kısmı işaretliyor.







kodu şöyle revize etmiştim.




Sub PARCALA()

Dim s1, s2 As Worksheet
Dim SonSat1, SonSat2 As Long
Dim baslangic, bitis As Date
baslangic = Time
Set s1 = Worksheets("Sayfa1")
Set s2 = Worksheets("Sayfa2")
SonSat2 = s1.Range("A" & Rows.Count).End(xlUp).Row
s1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T1"), Unique:=True

SonSat1 = s1.Range("T" & Rows.Count).End(xlUp).Row

For i = 2 To SonSat1
Aranan = s1.Cells(i, "T")
s2.Cells.Clear
s1.Range("A1:N" & SonSat2).AutoFilter Field:=2, Criteria1:=Aranan
s1.Range("A:N").Copy

s2.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
s2.Range("A1").PasteSpecial
Application.DisplayAlerts = False
s2.Select
ActiveSheet.Copy
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & Aranan & ".xls" 'Environ("USERPROFILE") & "\Desktop\" & ActiveSheet.Name & ".xls"
.Close
End With
s1.Select

Next
s1.Range("A1:N1").AutoFilter
s1.Range("T:T").Clear
s2.Cells.Clear
bitis = Time
MsgBox Format(bitis - baslangic, "hh:mm:ss") & " Sürede İşlem Tamamlandı" & vbLf & Application.UserName, _
vbInformation, "ASKM"
End Sub




Nerede hata yapıyorum
 
Verilerinizin olduğu sayfa ismi Sayfa1 mi? Değilse Set s1 = Worksheets("Sayfa1") kısmını değiştirin.
 
askm' Alıntı:
Verilerinizin olduğu sayfa ismi Sayfa1 mi? Değilse Set s1 = Worksheets("Sayfa1") kısmını değiştirin.
Genişletmek için tıkla ...

başlattım. çalışıyor. bakalım kaç dk sürecek. bu iş aslında farklı bir yazılım diliyle ve PHP ile bir kadaş yazmış ve veri tabanında çalıştıracak halletmiş. biz de onu kullanabiliyoruz ama ben excelde çok zor olmadan halledileceğini düşündüğüm için bu alanı özellikle öğrenmek istedim. tekrar teşekkürler.


Merak ve öğrenme niyetiyle bir sorum olacak. Neden Sayfa2 yi kullanıyorsunuz. direk Sayfa1 den almanın sıkıntısı var mı?
 
Sayfayı komple kaydediyorum. Sayfa1 de veri süz yapsam da kaydet deyince süzülmüş verilerde gidecek. Yani her kayıtta aynı veriler gitmiş gibi olacak. Yalnız filtre kısmı farklı olacak.
 
81 İl yaklaşık 10 dk da yaptı. şimdi de şube bazlı yaptırıyorum. 400 civarı şube var. bakalım kaç dk sürecek.
 
askm' Alıntı:
Sayfayı komple kaydediyorum. Sayfa1 de veri süz yapsam da kaydet deyince süzülmüş verilerde gidecek. Yani her kayıtta aynı veriler gitmiş gibi olacak. Yalnız filtre kısmı farklı olacak.
Genişletmek için tıkla ...

üstad cumadan bırakmıştım, yaklaşık 850 kadar şubeyi 1 saat 40 dk da böldü. Ama bu sefer farklı bir sorun oldu. Kod ilk başta illerin isimlerinin olduğu B sütununa göre filtre edip parçalıyordu aşağıdaki gibi.

s1.Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopytoRange:=Range("T1"), Unique:=True


Bu kısım başarılı olduktan sonra esas işlem olan şube koduna göre yapması için
ilgili sütuna yönlendirme yaptım yani A sütununa.


s1.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopytoRange:=Range("T1"), Unique:=True


Kod da yaptım tek değişiklik bu oldu. Bu sefer excel isimleri şube kodu oldu şube sayısı kadar excel oldu çok güzel ama sütün isimlerinin olduğu satırı koplayamış altına verileri almamıştı. Tüm tablolar böyleydi. Nerede hata yaptım acaba. Nasıl düzeltiriz. (Tekrar İl adına göre çalıştırdım düzgün çalıştı. verileri de basmış)
 
Çok enteresan ve biraz da saçma gibi ama. Excel A sütununda bulunan şube_kodu ile B sütundan bulunan il adlarının yerini değiştirdik. Ve şube koduna göre de filtre yapıp verileri de bastı. Ben şok...

Bunu daha mantıklı bir şekilde yapabilirsek sevinirim. :)
 
Makroyu hızlandırmak adına. filtre sonrası kopyalamada sadece verinin bulunduğu yeri kopyalayıp yapıştırabilir miyiz. A:N nin tamamı üzerinden işlem yapmak baya yavaşlatıyor.
 
Filtreleme sonrası Ado ile veri aktarımı yaparsanız hızlı olur. Bu hafta bakamam. Eğer bakan olmazsa haftaya bakarım inşallah.
 
askm' Alıntı:
Filtreleme sonrası Ado ile veri aktarımı yaparsanız hızlı olur. Bu hafta bakamam. Eğer bakan olmazsa haftaya bakarım inşallah.
Genişletmek için tıkla ...

Ado kullanmayı bilmiyorum da. biraz araştırıp yapmaya çalışayım. yardımlarınız için teşekkür ederim. :ok:: Başka yardım eden de olursa iyi yoksa sizin cevabınızı bekliyorum.
 
ysf-drsn' Alıntı:
Çok enteresan ve biraz da saçma gibi ama. Excel A sütununda bulunan şube_kodu ile B sütundan bulunan il adlarının yerini değiştirdik. Ve şube koduna göre de filtre yapıp verileri de bastı. Ben şok...

Bunu daha mantıklı bir şekilde yapabilirsek sevinirim. :)
Genişletmek için tıkla ...

hatamı buldum ve düzelttim.

s1.Range("A1:N" & SonSat2).AutoFilter Field:=2, Criteria1:=Aranan

A sütununda aramak istediğimde

bulunan Field:=2 alanı olduğu için B sütununa bakıp bulamıyordu. o kısmı 1 yapınca artık A sütununa bakıyor. iki alını değiştirerek istediğim sütunda göre gruplama yaptırabilirim.
 
askm' Alıntı:
Hızı nasıl.
Genişletmek için tıkla ...


hızı büyük dosyalarda yavaş ama işimi görüyor teşekkür ederim.

şimdi çok acil bir konu var. mevcut makro kodundaki yeni oluşturulan dosya uzantısını .xls yapsam da eski versiyon bilgisayarlarda açmıyor. dosyayı bilgisayarımda açıp farklı kaydet ile 97-03 excel ve .xls formatında kaydedersem o zaman sorunsuz açıyor. Bu işleme gerek kalmadan Makro ile bu sorunu nasıl çözebiliriz. Çok sayıda dosya var ve konu acil. Yardım lütfen..
 
ysf-drsn' Alıntı:
hızı büyük dosyalarda yavaş ama işimi görüyor teşekkür ederim.

şimdi çok acil bir konu var. mevcut makro kodundaki yeni oluşturulan dosya uzantısını .xls yapsam da eski versiyon bilgisayarlarda açmıyor. dosyayı bilgisayarımda açıp farklı kaydet ile 97-03 excel ve .xls formatında kaydedersem o zaman sorunsuz açıyor. Bu işleme gerek kalmadan Makro ile bu sorunu nasıl çözebiliriz. Çok sayıda dosya var ve konu acil. Yardım lütfen..
Genişletmek için tıkla ...


Yardımcı olabilecek yok mu? ????
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst