A sütununa göre aynı isimdeki satırları filtreleyip farklı dosya olarak kaydetme

caytug · 7 Ocak 2021

Arkadaşlar kolay gelsin,

makro.xlsm dosyasından çalıştırılacak makroyla,

(filtre_uygulanacak.xls) dosyasındaki verileri A sütununa göre aynı isimdeki satırları filtreleyip,
filtrelenecek A sütunundaki değerler (11111 , 22222 , 33333) tür.
bu değerleri (11111 = dosya1.xls , 22222 = dosya2.xls , 33333 = dosya3.xls) şeklinde (başlık satırı dahil)
(filtre_uygulanacak.xls) dosyasının bulunduğu klasöre dosya adı olarak kaydetmek mümkünmü.
Teşekkürler.

mancubus · 7 Ocak 2021

PHP:

Sub xlTR_192422_satirlari_filtrele_ayri_dosya_yap()

    Dim sKlasor As String
    Dim i As Long
    Dim vFiltreler
    Dim wWB As Workbook
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        .Calculation = xlCalculationManual
    End With
   
    sKlasor = ThisWorkbook.Path & "\klasör\"
    'Set wWB = Workbooks.Open(sKlasor & "filtre_uygulanacak.xls") 'dosya kapalıysa
    Set wWB = Workbooks("filtre_uygulanacak.xls") 'dosya açıksa
   
    With wWB.Sheets(1)
        .Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True
        vFiltreler = Application.Transpose(.Cells(1, .Columns.Count).CurrentRegion.Value)
        .Cells(1, .Columns.Count).CurrentRegion.Clear
   
        For i = 2 To UBound(vFiltreler)
            .Cells(1).AutoFilter Field:=1, 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
    End With

    'wWB.Close SaveChanges:=False 'filtre_uygulanacak.xls dosyasını kaydetmeden kapatmak için

    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

caytug · 7 Ocak 2021

Sayın mancubus,

ilginize teşekkür ederim, şimdi deneme fırsatım oldu.
Set wWB = Workbooks("filtre_uygulanacak.xls") 'dosya açıksa ( bu satırda hata veriyor)
aslında yapmak istediğimi tam izah edemediğimi farkettim.

(filtre_uygulanacak.xls) diye kastettiğim , dosya aç diyalog penceresinden seçilecek herhangi bir isimde olan kapalı xls dosyasıdır.
bu dosyada a sütununda 17 birime ait kodlar var, ben bu kodları filtreleyerek ait olduğu birim adıyla ayrı ayrı dosya oluşturmak istiyorum.(başlıkları dahil)

birim kodlarını 11111, 22222, 33333 diye örnekledim, bunlar gerçek kodlar değil tabiki.
kodlar ardışık gelmediği gibi dosya adlarıda ardışık olmayacak ve farklı farklı olacak.

Haliyle makro içinde kodlara karşılık gelen birim isimlerini sabitlemek gerekiyorki dosya adlarını ben belirliyebileyim.
(11111 = personel , 22222 = maliişler , 33333 = evrak ) vs.

Korhan Ayhan · 8 Ocak 2021

Alternatif;

Deneyiniz.

C++:

Option Explicit

Sub Filtrele_Farkli_Kaydet()
    Dim Zaman As Double, Dosya As Variant, Dizi As Object, XL_App As Object
    Dim K1 As Workbook, S1 As Worksheet, K2 As Workbook, S2 As Worksheet
    Dim Son As Long, X As Long, Veri As Variant, Kriter As Variant, Say As Long
    
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
   
    If Dosya = "" Then
        MsgBox "İşleme devam edebilmeniz için dosya seçmelisiniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer

    Application.ScreenUpdating = 0

    Set Dizi = CreateObject("Scripting.Dictionary")
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
   
    Set K1 = GetObject(Dosya)
    Set S1 = K1.Sheets("Sheet0")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
    Veri = S1.Range("A2:A" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then Dizi.Item(Veri(X, 1)) = 1
    Next

    XL_App.Application.DisplayAlerts = False
    
    For Each Kriter In Dizi.Keys
        S1.Range("A1:F" & S1.Rows.Count).AutoFilter 1, Kriter
        Set K2 = XL_App.Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        S1.Range("A1").CurrentRegion.Copy
        S2.Paste S2.Range("A1")
        Say = Say + 1
        K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
        Application.PathSeparator & "Dosya" & Say & ".xls", 56
        K2.Close 0
    Next
    
    Application.CutCopyMode = False
    K1.Close 0
    XL_App.Quit
    XL_App.Application.DisplayAlerts = True
    
    Set Dizi = Nothing
    Set XL_App = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    
    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

caytug · 8 Ocak 2021

Sayın Korhan teşekkür ederim, Ellerinize sağlık

mancubus · 8 Ocak 2021

PHP:

Sub xlTR_192422_satirlari_filtrele_ayri_dosya_yap()

    Dim sKlasor As String, sDosya As String
    Dim i As Long
    Dim vFiltreler
    Dim wWB As Workbook
    
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then sDosya = .SelectedItems(1) Else Exit Sub
    End With
    '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.
    
    Set wWB = Workbooks.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(1).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 A 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:=1, 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: A 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.
        
    End With

    'wWB.Close SaveChanges:=False
    'AÇIKLAMA: açılan dosyayı kaydetmeden kapatmak için. aktif hale getirmek için başındaki tek tırnak işaretini siliniz.

End Sub

caytug · 8 Ocak 2021

Sayın mancubus,
tekrar döndüğünüz için teşekkür ederim.Sizin kodlarınızda farklı açıdan tam sonuç veriyor, ellerinize sağlık
fakat benim ihtiyacım olan sonuç ,sayın Korhanın kodlarıyla oynayarak elde ettiğim aşağıdaki kodlar oldu.
******************************************************************************************
Option Explicit

Sub Filtrele_Farkli_Kaydet()
Dim Zaman As Double, Dosya As Variant, Dizi As Object, XL_App As Object
Dim K1 As Workbook, S1 As Worksheet, K2 As Workbook, S2 As Worksheet
Dim Son As Long, X As Long, Veri As Variant, Kriter As Variant, Say As Long
Dim Dosyaadi As Variant

Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)

If Dosya = "" Then
MsgBox "İşleme devam edebilmeniz için dosya seçmelisiniz!", vbCritical
Exit Sub
End If

Zaman = Timer

Application.ScreenUpdating = 0

Set Dizi = CreateObject("Scripting.Dictionary")
Set XL_App = CreateObject("Excel.Application")
XL_App.Visible = False

Set K1 = GetObject(Dosya)
Set S1 = K1.Sheets("Sheet0")

Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
If Son <= 2 Then Son = 3
Veri = S1.Range("A2:A" & Son).Value

For X = LBound(Veri, 1) To UBound(Veri, 1)
If Veri(X, 1) <> "" Then Dizi.Item(Veri(X, 1)) = 1
Next

XL_App.Application.DisplayAlerts = False

For Each Kriter In Dizi.Keys
S1.Range("A1:F" & S1.Rows.Count).AutoFilter 1, Kriter
Set K2 = XL_App.Workbooks.Add(1)
Set S2 = K2.Sheets(1)
S1.Range("A1").CurrentRegion.Copy
S2.Paste S2.Range("A1")

If Kriter = "33333" Then Dosyaadi = "01-personel"
If Kriter = "11111" Then Dosyaadi = "02-maliişler"
If Kriter = "22222" Then Dosyaadi = "03-evrak"

K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
Application.PathSeparator & Dosyaadi & ".xls", 56
K2.Close 0
Next

Application.CutCopyMode = False
K1.Close 0
XL_App.Quit
XL_App.Application.DisplayAlerts = True

Set Dizi = Nothing
Set XL_App = Nothing
Set K1 = Nothing
Set S1 = Nothing
Set K2 = Nothing

Application.ScreenUpdating = 1

MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
******************************************************************************
bu haliyle istediğim gibi sonuç aldığım dosyayıda ekliyorum.Tekrar teşekkürler

caytug · 9 Ocak 2021

İyi günler,
Yukarıdaki kodlara göre filtrelenip farklı kaydedilen dosyaların (sayfa1) olarak gelen sayfa ismi (sheet0) olarak kaydedilmesi ihtiyaç oldu.

Korhan Ayhan · 9 Ocak 2021

Şu satırın altına;

Set S2 = K2.Sheets(1)

Bu satırı ekleyip deneyiniz.

S2.Name = "Sheet0"

caytug · 9 Ocak 2021

Sayın Korhan teşekkürler

caytug · 10 Ocak 2021

Sayın Korhan,

If Kriter = "33333" Then Dosyaadi = "01-personel"
If Kriter = "11111" Then Dosyaadi = "02-maliişler"
If Kriter = "22222" Then Dosyaadi = "03-evrak"

Filtre uygulanacak dosyada (11111) kriteri yoksa kritere karşılık gelen "02-maliişler" dosyasını oluşturup başlıkları alıp, C2,D2,E2,F2 hücrelerine sıfır koymak mümkün olurmu.(bu şekilde17 kriterim var birden fazla kriterde adı çıkmayabiliyor, ama dosya olarak gerekli.Teşekkürler

Korhan Ayhan · 10 Ocak 2021

Filtre kriterleri zaten filtre uygulanacak dosyanızın "A" sütunundaki benzersiz verileri baz alınarak oluşmaktadır.

Eğer sizin bahsettiğiniz bu 11111-22222-33333 sabit kriter ise koda ekleme yapmak gerekir.

caytug · 10 Ocak 2021

Sayın Korhan,
Kriterler sabit (orjinal dosyada 17 adet her birime denk gelen sabit kriter)

Korhan Ayhan · 10 Ocak 2021

Deneyiniz.

C++:

Option Explicit

Sub Filtrele_Farkli_Kaydet()
    Dim Zaman As Double, Dosya As Variant, Dizi As Object, XL_App As Object
    Dim K1 As Workbook, S1 As Worksheet, K2 As Workbook, S2 As Worksheet, Say As Long
    Dim Son As Long, X As Long, Veri As Variant, Kriter As Variant, Dosya_Adi As String
    
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
   
    If Dosya = "" Then
        MsgBox "İşleme devam edebilmeniz için dosya seçmelisiniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer

    Application.ScreenUpdating = 0

    Set Dizi = CreateObject("Scripting.Dictionary")
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
   
    Set K1 = GetObject(Dosya)
    Set S1 = K1.Sheets("Sheet0")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
    Veri = S1.Range("A2:A" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then Dizi.Item(Veri(X, 1)) = 1
    Next

    XL_App.Application.DisplayAlerts = False
    
    For Each Kriter In Dizi.Keys
        Dosya_Adi = ""
        S1.Range("A1:F" & S1.Rows.Count).AutoFilter 1, Kriter
        Set K2 = XL_App.Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        S2.Name = "Sheet0"
        S1.Range("A1").CurrentRegion.Copy
        S2.Paste S2.Range("A1")
        
        If Dosya_Adi = "" Then
            Say = Say + 1
            Dosya_Adi = "Dosya " & Say
        End If
        
        K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
        Application.PathSeparator & Dosya_Adi & ".xls", 56
        K2.Close 0
    Next
    
    If Not Dizi.Exists(11111) Then
        Set K2 = XL_App.Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        S2.Name = "Sheet0"
        S1.Range("A1:F1").Copy
        S2.Paste S2.Range("A1")
        S2.Range("A2:F2") = 0
        Dosya_Adi = "02-maliişler"
        K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
        Application.PathSeparator & Dosya_Adi & ".xls", 56
        K2.Close 0
    End If
    
    If Not Dizi.Exists(22222) Then
        Set K2 = XL_App.Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        S2.Name = "Sheet0"
        S1.Range("A1:F1").Copy
        S2.Paste S2.Range("A1")
        S2.Range("A2:F2") = 0
        Dosya_Adi = "03-evrak"
        K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
        Application.PathSeparator & Dosya_Adi & ".xls", 56
        K2.Close 0
    End If
    
    If Not Dizi.Exists(33333) Then
        Set K2 = XL_App.Workbooks.Add(1)
        Set S2 = K2.Sheets(1)
        S2.Name = "Sheet0"
        S1.Range("A1:F1").Copy
        S2.Paste S2.Range("A1")
        S2.Range("A2:F2") = 0
        Dosya_Adi = "01-personel"
        K2.SaveAs CreateObject("Scripting.FileSystemObject").GetParentFolderName(Dosya) & _
        Application.PathSeparator & Dosya_Adi & ".xls", 56
        K2.Close 0
    End If
    
    Application.CutCopyMode = False
    K1.Close 0
    XL_App.Quit
    XL_App.Application.DisplayAlerts = True
    
    Set Dizi = Nothing
    Set XL_App = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    
    Application.ScreenUpdating = 1
    
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

caytug · 10 Ocak 2021

Sayın Korhan,

If Dosya_Adi = "" Then
Say = Say + 1
Dosya_Adi = "Dosya " & Say
End If

bu kısmı silip aynı yere

If Kriter = "33333" Then Dosya_adi = "01-personel"
If Kriter = "11111" Then Dosya_adi = "02-maliişler"
If Kriter = "22222" Then Dosya_adi = "03-evrak"

bu kodları yazınca tam istediğim gibi oldu. Vakit ayırdığınız çok teşekkür ederim, ellerinize sağlık.

A sütununa göre aynı isimdeki satırları filtreleyip farklı dosya olarak kaydetme

caytug

Ekli dosyalar

mancubus

Destek Ekibi

caytug

Korhan Ayhan

Administrator

caytug

mancubus

Destek Ekibi

caytug

Ekli dosyalar

caytug

Korhan Ayhan

Administrator

caytug

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug