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

baehsaar · 22 Eylül 2020

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?

Ömer · 22 Eylül 2020

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

.

baehsaar · 22 Eylül 2020

Kitap3.xlsx - 9 KB
ornek.xlsx - 8 KB

Kitap3 te şehir isimleri ve sahalar var, bu sahaları örnek dosya formatında şehir bazlı çekip yine şehir isimlerinde farkli exceller oluşturacak.

Ömer · 26 Eylül 2020

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

baehsaar · 26 Eylül 2020

Ö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

İ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?

Ömer · 26 Eylül 2020

#4 numaralı mesajdaki kodları güncelledim, tekrar deneyiniz.

baehsaar · 26 Eylül 2020

Tamamdır üstad süper çok teşekkür ederim.

baehsaar · 26 Eylül 2020

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?

Ömer · 26 Eylül 2020

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

baehsaar · 27 Eylül 2020

Tamamdır şimdi denedim çalıştı, Allah tuttuğunuzu altın etsin her caliştırdığımda dua edicem size

baehsaar · 27 Eylül 2020

Adana hariç diğerleri karışmış

Mesela Kayseri..

Ömer · 27 Eylül 2020

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.

baehsaar · 27 Eylül 2020

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

baehsaar · 28 Eylül 2020

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

").Select
ActiveSheet.Paste
Columns("B:B").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("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

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

baehsaar

Ömer

Moderatör

Dosya Yükle - Dosya Upload

baehsaar

Ömer

Moderatör

baehsaar

Ömer

Moderatör

baehsaar

baehsaar

Ömer

Moderatör

baehsaar

baehsaar

Ömer

Moderatör

baehsaar

baehsaar