caytug
Altın Üye
- Katılım
- 12 Şubat 2014
- Mesajlar
- 47
- Excel Vers. ve Dili
- 2003-2010
- Altın Üyelik Bitiş Tarihi
- 12-10-2025
sağolsun sayın mancubus'un daha önce verdiği aşağıdaki kodlar ile makro.xlsm çalıştırılarak ,kapalı orjinal.xls dosyadan D sütununa göre filtrelenip tekil hale gelen hücre değerlerinin adıyla bulunduğu klasöre dosya oluşturuyor.
fakat şöyle bir şey gerekti, oluşturulan dosyalar kaydedilip kapatılmadan G sütununa da filtre uygulanıp tekil hale gelen hücre adlarının sayfa ismi olarak kaydedilip filtrelenen içeriğinde o sayfalara kopyalanmasını istiyorum, Aşağıdaki kodlara böyle bir ilave mümkün mü? Yardımlarınız için şimdiden teşekkürler.
Not: G Sütunu tarih ve saat formatında (05.10.2021 14:20:07) fakat sayfa isimleri (05.10.2021) sadece tarih formatında olmalı.
ilgili dosyaları ekliyorum.
Sub xlTR_192422_satirlari_filtrele_ayri_dosya_yap()
Dim sKlasor As String, sDosya As String
Dim kadar uzun
vFiltreler yok
Çalışma kitabı olarak wWB'yi karart
Application.FileDialog(msoFileDialogOpen) ile
.AllowMultiSelect = Yanlış
.InitialFileName = ThisWorkbook.Path
Eğer .Show = -1 ise sDosya = .SelectedItems(1) Else Exit Sub
İle bitmek
'AÇIKLAMA: parçalanacak dosyanın seçilmesi. seçilmez ise makro uyarı vermeden duracaktır.
sKlasor = Left(sDosya, InStrRev(sDosya, "\"))
'AÇIKLAMA: parçalanacak dosyanın klasör adının değişkene atanması. oluşan dosyalar aynı klasöre kaydedilecektir.
wWB = Çalışma Kitapları olarak ayarlayın.Open(sDosya)
'AÇIKLAMA: parçalanacak dosyanın açılması
With wWB.Sheets(1)
'AÇIKLAMA: parçalanacak verinin açılan dosyanın soldan 1. sheet'inde olduğu varsayılmıştır.
'başka bir sheet'te ise onun sıra / indis / index numarasını yazınız.
.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
vFiltreler = Application.Transpose(.Cells(1, .Columns.Count).CurrentRegion.Value)
.Cells(1, .Columns.Count).CurrentRegion.ClearContents
'AÇIKLAMA: advanced filter yöntemi ile D sütunundaki veriler tekil hale getirilmiş ve dizi değişkenine atanmıştır.
'bu verilerin departman mı, okulda şube mi, ligdeki takımlar mı, kişi isimleri mi oldukları makroyu ilgilendirmemektedir.
For i = 2 To UBound(vFiltreler)
.Cells(1).AutoFilter Field:=4, Criteria1:=vFiltreler(i)
.AutoFilter.Range.Copy
With Workbooks.Add
.Sheets(1).Cells(1).PasteSpecial
.SaveAs Filename:=sKlasor & vFiltreler(i) & ".xls", FileFormat:=xlWorkbookNormal
.Close SaveChanges:=True
End With
Next i
'AÇIKLAMA: D sütunundaki her tekil değer üzerinden veriyi filtreler, filtrelenen satırları boş bir dosyaya kopyalar
'boş dosyayı açılan dosyanın bulunduğu klasöre tekil değerin adını vererek xl 2003 ve öncesi formatında kaydeder.
'wWB.Close SaveChanges:=False ile Bitirin
'AÇIKLAMA: açılan dosyayı kaydetmeden kapatmak için. aktif hale getirmek için başındaki tek tırnak işaretini siliniz.
Alt Bitiş
fakat şöyle bir şey gerekti, oluşturulan dosyalar kaydedilip kapatılmadan G sütununa da filtre uygulanıp tekil hale gelen hücre adlarının sayfa ismi olarak kaydedilip filtrelenen içeriğinde o sayfalara kopyalanmasını istiyorum, Aşağıdaki kodlara böyle bir ilave mümkün mü? Yardımlarınız için şimdiden teşekkürler.
Not: G Sütunu tarih ve saat formatında (05.10.2021 14:20:07) fakat sayfa isimleri (05.10.2021) sadece tarih formatında olmalı.
ilgili dosyaları ekliyorum.
Sub xlTR_192422_satirlari_filtrele_ayri_dosya_yap()
Dim sKlasor As String, sDosya As String
Dim kadar uzun
vFiltreler yok
Çalışma kitabı olarak wWB'yi karart
Application.FileDialog(msoFileDialogOpen) ile
.AllowMultiSelect = Yanlış
.InitialFileName = ThisWorkbook.Path
Eğer .Show = -1 ise sDosya = .SelectedItems(1) Else Exit Sub
İle bitmek
'AÇIKLAMA: parçalanacak dosyanın seçilmesi. seçilmez ise makro uyarı vermeden duracaktır.
sKlasor = Left(sDosya, InStrRev(sDosya, "\"))
'AÇIKLAMA: parçalanacak dosyanın klasör adının değişkene atanması. oluşan dosyalar aynı klasöre kaydedilecektir.
wWB = Çalışma Kitapları olarak ayarlayın.Open(sDosya)
'AÇIKLAMA: parçalanacak dosyanın açılması
With wWB.Sheets(1)
'AÇIKLAMA: parçalanacak verinin açılan dosyanın soldan 1. sheet'inde olduğu varsayılmıştır.
'başka bir sheet'te ise onun sıra / indis / index numarasını yazınız.
.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
vFiltreler = Application.Transpose(.Cells(1, .Columns.Count).CurrentRegion.Value)
.Cells(1, .Columns.Count).CurrentRegion.ClearContents
'AÇIKLAMA: advanced filter yöntemi ile D sütunundaki veriler tekil hale getirilmiş ve dizi değişkenine atanmıştır.
'bu verilerin departman mı, okulda şube mi, ligdeki takımlar mı, kişi isimleri mi oldukları makroyu ilgilendirmemektedir.
For i = 2 To UBound(vFiltreler)
.Cells(1).AutoFilter Field:=4, Criteria1:=vFiltreler(i)
.AutoFilter.Range.Copy
With Workbooks.Add
.Sheets(1).Cells(1).PasteSpecial
.SaveAs Filename:=sKlasor & vFiltreler(i) & ".xls", FileFormat:=xlWorkbookNormal
.Close SaveChanges:=True
End With
Next i
'AÇIKLAMA: D sütunundaki her tekil değer üzerinden veriyi filtreler, filtrelenen satırları boş bir dosyaya kopyalar
'boş dosyayı açılan dosyanın bulunduğu klasöre tekil değerin adını vererek xl 2003 ve öncesi formatında kaydeder.
'wWB.Close SaveChanges:=False ile Bitirin
'AÇIKLAMA: açılan dosyayı kaydetmeden kapatmak için. aktif hale getirmek için başındaki tek tırnak işaretini siliniz.
Alt Bitiş