filitre hücerisindeki bilgilere göre kaydetme

[search77]

Arkadaşlar merhaba,

Ekli örnek dosyamda açıklamalarım mevcut, aslında istediğim çak basit ama çok uğraştım yapamadım

İstediğim filitre altındaki kişilere ait bilgileri seçip yeni bir excele kaydetme,

Bunu yapacak macro için yarımlarınızı rica ederim.

Saygı ve sevgilerimle.

 

[search77]

Hala cevap alamadım, bir yardım lütfen

Arkadaşlar yardımlarınızı rica ederim.

 

[search77]

arkadaşlar,

help help help

dögüyü bile yazmanız benim için yeterli olacak, acil yardım lüfennn

 

[Ömer]

Merhaba,

Daha önceki sorunuzun devamı olduğunu düşünerek masa üstünde Dosya adlı klasörde kayıt yaptırdım.

Sub SayfaKaydet()
 
Dim S1 As Worksheet, S2 As Worksheet, son As Long, dosya As String
 
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
son = S1.Cells(Rows.Count, "A").End(xlUp).Row
 
Application.ScreenUpdating = False
S2.Cells.Clear
 
Range("A1:J" & son).SpecialCells(xlCellTypeVisible).Copy S2.[A1]
 
    S2.Select
    dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
    "\[COLOR=red]Dosya[/COLOR]" & Application.PathSeparator & S2.[I2] & ".xls"
 
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=dosya
    ActiveWorkbook.Close
 
S2.Columns("A:J").EntireColumn.AutoFit
 
Application.ScreenUpdating = True
 
End Sub

.

 

[search77]

Ömer bey,

Öncelikle ilginizden dolayı çok teşekkür ederim. Fakat macroyu çalıştırdığımda sayfadaki tüm bilgileri alıyor ve I2 deki ilk ismi dosya ismi vererek kaydediyor.

Benim istediğim ise I2 deki filitre açılacak orada gördüğü her ismi tek tek seçerek seçtiğinde oluşan kayıtları sadece alarak yeni bir excel dosya olarak kaydedecek. Kaydederkende dosyaya vereceği isim filitre yaptığında karşısına çıkan isim olacak.

Yani 3 kayıt olacak "Ahmet Sucu, Hasan Tan, Sedat Kayıkçı" dosyaları ve sadece bu kişilere ait bilgiler olacak dosyların içinde.

Acaba macroyu bu şekilde yazabilir miyiz?

Şimdiden çok çok tşk ederim.

 

[Ömer]

İstediğim filitre altındaki kişilere ait bilgileri seçip yeni bir excele kaydetme,

Bu şekilde açıklamamıştınız.

Birazdan son açıklamanıza göre hazırlarım.

.

 

[Ömer]

Bu şekilde deneyiniz.

Sub SayfaKaydet()
 
Dim S1 As Worksheet, S2 As Worksheet, son As Long, dosya As String
Dim i As Long, IlkAdres As Variant, c As Range
 
Set S1 = Sheets("Sheet1")
Set S2 = Sheets("Sheet2")
 
Application.ScreenUpdating = False
 
S1.Range("A1:J1").Copy S2.Range("A1")
S1.[O:O].Clear
S2.Range("A2:J" & Rows.Count).ClearContents
 
S1.Range("I:I").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("O1"), Unique:=True
 
sat = 2
For i = 2 To S1.Cells(Rows.Count, "O").End(xlUp).Row
    With S1.Range("I:I")
        Set c = .Find(S1.Cells(i, "O"), , LookIn:=xlValues)
        If Not c Is Nothing Then
            IlkAdres = c.Address
            Do
 
                If S2.Range("A2") = "" Then
                    sat = 2
                End If
 
                S1.Range("A" & c.Row & ":J" & c.Row).Copy S2.Range("A" & sat)
                sat = sat + 1
 
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> IlkAdres
        End If
    End With
 
    S2.Select
    dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
    "\Dosya" & Application.PathSeparator & S2.[I2] & ".xls"
 
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=dosya
    ActiveWorkbook.Close
 
    S2.Columns("A:J").EntireColumn.AutoFit
    S2.Range("A2:J" & Rows.Count).ClearContents
 
Next i
 
S1.Select
[O:O].Clear
 
Application.ScreenUpdating = True
 
End Sub

.

 

[search77]

Ömer bey,

Perfect perfect perfect,

Elinize bilginize sağlık, ilginiz için çok çok teşekkürler.

Saygı ve sevgilerimle.