Datayı Sheetlere Dağıtmak

[evrenka]

Merhaba
Araştırdım ama benzer bi konu bulamadım.
Benim sorunum; elimde 20,000 satırlık bir data var. Bu datada iller bazında bilgiler var. Otomatik olarak her il için bir sheet açılmasını ve bu ile ait bilgilerin bu sheetlere gitmesini istiyorum. Sütunlar A' dan M' ye kadar.
Yardımlarınız için teşekkürler.

 

[Necdet]

Merhaba,

Örnek dosya ile sorunuzu destekleyiniz.

Gerekli bilgiyi veriyorsunuz ama yine eksik kalıyor. Örneğin il hangi sütunda belli değil.

 

[evrenka]

Dosyayı ekledim. Yardımlarınız için tektar teşekkürler.

 

[Merhum İdris SERDAR]

http://www.excel.web.tr/f119/verilerin-ilgili-sayfalar-na-formulle-dag-t-lmas-t20271.html

Buradaki dosyaları inceleyin.

.

 

[Necdet]

Merhaba,

Sayın yurttaş ilgili linki vermiş bende üzerinde çalışmıştım. Boşa gitmesin çalışma.

Option Compare Text
Sub Aktar()
Dim i As Long
Dim syf As String
Set s1 = Sheets("Sheet1")
Application.ScreenUpdating = False
Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("O1" _
    ), Unique:=True
    
Sayfa_Olustur
s1.Select
Range("O:O").Clear
For i = 2 To [A65536].End(3).Row
    syf = s1.Cells(i, "A")
    Set s2 = Sheets(syf)
    Range("A" & i & ":M" & i).Copy s2.Range("A" & s2.[A65536].End(3).Row + 1)
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Tamamlandı"
End Sub

Sub Sayfa_Olustur()
Dim c As String
Dim i As Long
Set s1 = Sheets("Sheet1")
For i = 2 To [O65536].End(3).Row
    c = Cells(i, "O")
    If Not SayfaVarMi(c) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = c
        s1.Range("A1:M1").Copy Sheets(c).[A1]
        s1.Select
    End If
Next i
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function