Filtreleyip Kaydetme

[ozkanweb]

Değerli üstatlarım,

Excelde bulunan bir sütundaki değerlere göre filtreleyip ayrı ayrı dosyalar halinde kaydetmesini istiyorum. Desteklerinizi rica ediyorum.

Ör: Şehir Adana olanları filtreleyip adana isminde ayrı excel olarak kaydetmesi.

Şehir Adı-Soyadı
Adana x
Adana y
Ankara z
İstanbul x
İstanbul y

 

[askm]

Örnek dosya eklerseniz dilediğinizi yapabiliriz.

 

[ozkanweb]

Örnek dosya ekledim.

Şehir isimlerine göre süzüp ayrı ayrı kayıt etmesini istiyorum. Adana'ları bir excel'e Ankara'ları bir excele gibi. Teşekkür ederim ilginize.

 

[askm]

Aşağıdaki kodları kullanabilirsiniz.

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("A:A").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:D" & SonSat2).AutoFilter Field:=1, Criteria1:=Aranan
    s1.Range("A:D").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:D1").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

 

[ozkanweb]

Aşağıdaki kodları kullanabilirsiniz.

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("A:A").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:D" & SonSat2).AutoFilter Field:=1, Criteria1:=Aranan
    s1.Range("A:D").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:D1").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

Bilginiz için teşekkürler. Sınırlı satır alıyor attırmam için ne yapmam gerek acaba hocam ?