Filtreleme özelliklerine göre yeni tablolara aktarma

[IsmailCem1]

Arkadaşlar,

Ekteki dosyada bulunan veriyi bölgelere göre filtreleyip sonrasında da filtrelenmiş seçeneği bölge adına göre ayrı ayrı
"Ege.xml", "Akdeniz.xml", "Karadeniz.xml" olarak masaüstüne kaydedebilen makro yazılımı konusunda yardımınıza ihtiyacım var. Makro kaydederek Office 2007'de bunu sağlayamadım.
VBA Code üzerinde de oynadım ancak uyumlu olmadı.
Yardımlarınızı bekliyorum

 

[Ömer]

Merhaba,

Module kopyalayarak çalıştırınız..

Sub VeriKaydet()
 
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
 
Application.ScreenUpdating = False
 
S1.Range("A1:E1").Copy S2.Range("A1")
S1.[K:K].Clear
S2.Range("A2:E65536").ClearContents
S1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("K1"), Unique:=True
 
sat = 2
For i = 2 To S1.Cells(Rows.Count, "K").End(xlUp).Row
    With S1.Range("A:A")
        Set c = .Find(S1.Cells(i, "K"), , 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 & ":E" & 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") & _
    Application.PathSeparator & [A2] & ".[B][COLOR=red]xls[/COLOR][/B]"
 
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=dosya
    ActiveWorkbook.Close
 
    Range("A2:E65536").ClearContents
 
Next i
 
S1.Select
[K:K].Clear
 
Application.ScreenUpdating = True
 
End Sub

.

 

[IsmailCem1]

Hocam ilgili makroyu denediğimde,

"Subscript out of range" hatası vermektedir.

Nasıl yardımcı olabilirsiniz?

 

[Ömer]

#2 nolu mesajı düzenledim. Tekrar denermisiniz.

Eğer yine hata verirse deneyip hata aldığınız dosyayı eklermisiniz..

.

 

[IsmailCem1]

Bu listeyi başka tablolarda da uygulamak, yine filtreleme sonuçlarına göre göndermek istiyorum. Ancak veri boyutları çok farklı. Filtrelenecek veriler de farklı. Genel bir kullanım koşulu için yazılması muhtemel bir makro var mıdır? Çünkü bu makroyu tüm çalışmalarımda kullanamıyorum. Bir rica daha, ".xls" formatında olması gerekiyor kaydedilecek dosyaların.

 

[Ömer]

Başka tablolarada uyarlayabilirsiniz. Ayrıca dosyalar xls formatında kayıt oluyor. ( Bu bölümü kırmızı ile işaretlemiştim )

 

[IsmailCem1]

Bir de bu yolla denemek istedim

Sub Makro1()
'
' Makro1 Makro
'

'
Selection.AutoFilter
Sheets("Sayfa2").Select
Range("A2").Select
ActiveCell.FormulaR1C1 = "Ege Bölgesi"
Sheets("Sayfa1").Select
ActiveSheet.Range("$A$1:$E$167").AutoFilter Field:=1, Criteria1:= _
"=Ege Bölgesi", Operator:=xlAnd
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Kitap1").Activate
ActiveSheet.Paste
Burada kırmızı ile belirtilen hücrelerde yeni bir excel sayfası açıp seçimi yapıştırmaya çalışıyorum.
Application.CutCopyMode = False
Range(Selection, Selection.End(xlDown)).Select
Columns("A:E").EntireColumn.AutoFit
Range("A1").Select
ChDir "C:\Documents and Settings\CO62571\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\CO62571\Desktop\Ege Bölgesi.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Range("A1").Select
Selection.AutoFilter
End Sub

--------------------------------------------------------------------------
Referans almak için yeni bir sayfa (Sayfa2) açtım. Sayfa 2'ye kopyaladığım bütün bölge isimlerine göre bu işlemi gerçekleştirmeye çalışıyorum. Yukarıda kırmızı ile belirttiğim kısım(kopyalanan hücrelerin yeni bir excel sayfası açıp seçimi yapıştırılması) ve sayfa 2'deki bütün bölgeler için yapılması için yazılacak kod kısmında takılıp kaldım.
--------------------------------------------------------------------------
Bu konuda yardımcı olabilir misiniz?
Şimdiden teşekkürler