• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Bir exceldeki bilgileri kullanarak aynı isimli farklı exceller oluşturmak

B

baehsaar

Katılım
7 Kasım 2016
Mesajlar
9
Excel Vers. ve Dili
Excel 2016
Merhaba,

1 tane excel dosyam var, dosyamda şehir isimleri ve yanında da saha isimleri var. Ben o toplu listeden şehirleri ve şehirdeki sahalardan ayrı ayrı şehir ismi şeklinde exceller yaptırtmak istiyorum. Yani örneğin ADANA.xls isimli bir dosyam olacak ve orda Adana sahaları olacak şekilde...Nasıl bir makro yazmalıyım?
 
Merhaba,

Sorunuzu örnek dosya ekleyerek açıklayınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.
dosya.co

.
 
Merhaba,

İşlerim dolayısıyla bugün inceleyebildim.
Kitap3 dosyasına kodları ekleyip çalıştırın.
Kod: 
Sub kitap_olustur()
   
    Dim S1 As Worksheet, Sx As Worksheet, i As Long, d As Object, deg As String
    Dim yol As String, dosya As String, t As Byte, a, son As Long
   
    Set S1 = Sheets("Sayfa1")
   
    yol = ThisWorkbook.Path & "\"
    Set d = CreateObject("Scripting.Dictionary")
    son = S1.Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = 2 To son
        deg = S1.Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
    Next i
   
    Sheets.Add.Name = "XXX"
    Set Sx = Sheets("XXX")
    Sx.Range("A1") = "NO"
    Sx.Range("A2") = 1
   
    a = d.keys
    For i = 0 To d.Count - 1
        S1.Range("A:B").AutoFilter Field:=1, Criteria1:=a(i)
        S1.Range("A1").CurrentRegion.Copy Sx.Range("B1")
        son = Sx.Cells(Rows.Count, "B").End(xlUp).Row
        Sx.Range("A2:A" & son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
        Sx.Range("A1:A" & son).Borders.LineStyle = 1
        dosya = yol & a(i) & ".xlsx"
        ActiveSheet.Copy
        With ActiveWorkbook
            .ActiveSheet.Name = "Sayfa1"
            .SaveAs Filename:=dosya
            .Close
        End With
    Next i
   
    Sx.Delete
    Application.DisplayAlerts = True
   
    On Error Resume Next
    S1.ShowAllData
   
    MsgBox "İşlem Bitti."
   
End Sub
 
Ömer' Alıntı:
Sub kitap_olustur() Dim S1 As Worksheet, Sx As Worksheet, i As Long, d As Object, deg As String Dim yol As String, dosya As String, t As Byte, a, son As Long Set S1 = Sheets("Sayfa1") yol = ThisWorkbook.Path & "\" Set d = CreateObject("Scripting.Dictionary") son = S1.Cells(Rows.Count, "A").End(xlUp).Row Application.ScreenUpdating = False Application.DisplayAlerts = False For i = 2 To son deg = S1.Cells(i, "A") If Not d.exists(deg) Then d.Add deg, Nothing End If Next i Sheets.Add.Name = "XXX" Set Sx = Sheets("XXX") a = d.keys For i = 0 To d.Count - 1 S1.Range("A:B").AutoFilter Field:=1, Criteria1:=a(i) S1.Range("A1").CurrentRegion.Copy Sx.Range("A1") dosya = yol & a(i) & ".xlsx" ActiveSheet.Copy With ActiveWorkbook .SaveAs Filename:=dosya .Close End With Next i Sx.Delete Application.DisplayAlerts = True On Error Resume Next S1.ShowAllData MsgBox "İşlem Bitti." End Sub
Genişletmek için tıkla ...
İnanılmaz işime yaradı çok ama çok teşekkür ederim, ellerinize sağlık...İki basit sorum daha var sheet ismi XXX değilde sayfa1 olabilir mi ? Birde orjinal "örnek" dosyasında en solda numaralar vardı o eklenebilir mi?
 
#4 numaralı mesajdaki kodları güncelledim, tekrar deneyiniz.
 
Bir hata daha çıktı saha isimlerinin B kolonunda olması lazım, C kolonuna kaymış o yüzden benim diğer makrom hata veriyor bu düzeltilebilir mi hocam?
 
B ile C yermi değiştirmesi gerekiyor?
Sayfa1 içinde istediğinizi yanlış anlamışım, onu da düzelttim.
Kod: 
Sub kitap_olustur()
    
    Dim S1 As Worksheet, Sx As Worksheet, i As Long, d As Object, deg As String
    Dim yol As String, dosya As String, t As Byte, a, son As Long
    
    Set S1 = Sheets("Sayfa1")
    
    yol = ThisWorkbook.Path & "\"
    Set d = CreateObject("Scripting.Dictionary")
    son = S1.Cells(Rows.Count, "A").End(xlUp).Row

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For i = 2 To son
        deg = S1.Cells(i, "A")
        If Not d.exists(deg) Then
            d.Add deg, Nothing
        End If
    Next i
    
    Sheets.Add.Name = "XXX"
    Set Sx = Sheets("XXX")
    
    a = d.keys
    For i = 0 To d.Count - 1
        Sx.Cells.Clear
        Sx.Range("A1") = "NO": Sx.Range("A2") = 1
        S1.Range("A:B").AutoFilter Field:=1, Criteria1:=a(i)
        S1.Range("A1").CurrentRegion.Copy Sx.Range("B1")
        son = Sx.Cells(Rows.Count, "B").End(xlUp).Row
        Sx.Range("A2:A" & son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
        Sx.Range("A1:A" & son).Borders.LineStyle = 1
        dosya = yol & a(i) & ".xlsx"
        ActiveSheet.Copy
        With ActiveWorkbook
            .ActiveSheet.Name = "Sayfa1"
            .SaveAs Filename:=dosya
            .Close
        End With
    Next i
    
    Sx.Delete
    Application.DisplayAlerts = True
    
    On Error Resume Next
    S1.ShowAllData
    
    MsgBox "İşlem Bitti."
    
End Sub
 
Tamamdır şimdi denedim çalıştı, Allah tuttuğunuzu altın etsin her caliştırdığımda dua edicem size:)
 
Detaylı deneme yapmadığım için hatalar olabiliyor maalesef. Sayfa içeriğini silmeyi atladığım için olmuş.
#9. mesajı güncelledim, tekrar deneyiniz.
 
Ok çok teşekkürler bu sağlıklı bir şekilde çalıştı fakat daha önceki hata olmuş yine yani cell isimleri B de, Regions C kolonunda olmalıydı:) Örnek dosyasında olduğu gibi yani..


No

SAHA İSMİ

REGION
 
Biraz iptidai oldu ama hallettim:) Eklediğim yeri kırmızıya boyadım.

Sub kitap_olustur()

Dim S1 As Worksheet, Sx As Worksheet, i As Long, d As Object, deg As String
Dim yol As String, dosya As String, t As Byte, a, son As Long

Set S1 = Sheets("Sayfa1")

yol = ThisWorkbook.Path & "\"
Set d = CreateObject("Scripting.Dictionary")
son = S1.Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To son
deg = S1.Cells(i, "A")
If Not d.exists(deg) Then
d.Add deg, Nothing
End If
Next i

Sheets.Add.Name = "XXX"
Set Sx = Sheets("XXX")

a = d.keys
For i = 0 To d.Count - 1
Sx.Cells.Clear
Sx.Range("A1") = "NO": Sx.Range("A2") = 1
S1.Range("A:B").AutoFilter Field:=1, Criteria1:=a(i)
S1.Range("A1").CurrentRegion.Copy Sx.Range("B1")
son = Sx.Cells(Rows.Count, "B").End(xlUp).Row
Sx.Range("A2:A" & son).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
Sx.Range("A1:A" & son).Borders.LineStyle = 1
Columns("C:C").Select
Selection.Cut
Columns("D:D").Select
ActiveSheet.Paste
Columns("B:B").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("D:D").Select
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Range("A1").Select

dosya = yol & a(i) & ".xlsx"
ActiveSheet.Copy
With ActiveWorkbook
.ActiveSheet.Name = "Sayfa1"
.SaveAs Filename:=dosya
.close

End With
Next i

Sx.Delete
Application.DisplayAlerts = True

On Error Resume Next
S1.ShowAllData

MsgBox "İşlem Bitti."

End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst