Formül-Makro yardımıyla yeni çalışma kitabı

[deuve]

Merhaba, benim şöyle bir sorunum var ki; bir excell'in içinde a sütununda iller yazmakta (İstanbul - İzmir vs.) bu illerin karşısında ise ilçer yer almakta öyle ki b sütunundan başlayıp devam eden a sütununda yazan ilin ilçeleri var. Şimdi soruma gelecek olursak; öyle bir formül yada makro yazmalıyım ki; a sütununda yazan istanbul için yeni bir excell oluşturmalı ve bu excell'in içinde istanbul ve ilçeleri yer almalıdır. Bu konuda desteğinizi beklemekteyim üstadlar. Tanışma bölümünü bulamadım kendimi tanıtamadım dolayısıyla kusuruma bakmayın.

 

[PLİNT]

Merhaba
Ek dosyadaki gibi işinize yararmı?
http://www.dosya.tc/server12/0n44t3/IL.zip.html

[SIZE="2"]Sub Düğme1_Tıklat()
Set s1 = ThisWorkbook.Sheets("Sayfa1")
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "\" & "İLLER2") = False Then ds.CreateFolder yol & "\" & "İLLER2"
sat = s1.Cells(Rows.Count, 1).End(3).Row
s1.Range("A2:F" & sat).Sort Key1:=s1.Cells(2, 1), Order1:=xlAscending
Application.ScreenUpdating = False
For a = 2 To sat
If WorksheetFunction.CountIf(s1.Range("A1:A" & a), s1.Cells(a, 1)) = 1 Then
x = WorksheetFunction.CountIf(s1.Range("A1:A" & sat), s1.Cells(a, 1))
Application.Workbooks.Add 1
ad = s1.Cells(a, 1).Value
With ActiveWorkbook
For b = a To a + x - 1
s = s + 1
.Sheets(1).Range("A" & s & ":B" & s).Value = s1.Range("A" & b & ":B" & b).Value
Next
.SaveAs Filename:=yol & "İLLER2\" & ad & ".xlsx", FileFormat:=51
.Close savechanges:=True
End With
a = a + x - 1: s = 0
End If
Next
Application.ScreenUpdating = True
MsgBox "Dosyalar Bu Kitabın Yanında oluşturulan İLLER2 Klasörü içerisine Eklendi"
End Sub[/SIZE]

 

[deuve]

Merhaba
Ek dosyadaki gibi işinize yararmı?
http://www.dosya.tc/server12/0n44t3/IL.zip.html

[SIZE="2"]Sub Düğme1_Tıklat()
Set s1 = ThisWorkbook.Sheets("Sayfa1")
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "\" & "İLLER2") = False Then ds.CreateFolder yol & "\" & "İLLER2"
sat = s1.Cells(Rows.Count, 1).End(3).Row
s1.Range("A2:F" & sat).Sort Key1:=s1.Cells(2, 1), Order1:=xlAscending
Application.ScreenUpdating = False
For a = 2 To sat
If WorksheetFunction.CountIf(s1.Range("A1:A" & a), s1.Cells(a, 1)) = 1 Then
x = WorksheetFunction.CountIf(s1.Range("A1:A" & sat), s1.Cells(a, 1))
Application.Workbooks.Add 1
ad = s1.Cells(a, 1).Value
With ActiveWorkbook
For b = a To a + x - 1
s = s + 1
.Sheets(1).Range("A" & s & ":B" & s).Value = s1.Range("A" & b & ":B" & b).Value
Next
.SaveAs Filename:=yol & "İLLER2\" & ad & ".xlsx", FileFormat:=51
.Close savechanges:=True
End With
a = a + x - 1: s = 0
End If
Next
Application.ScreenUpdating = True
MsgBox "Dosyalar Bu Kitabın Yanında oluşturulan İLLER2 Klasörü içerisine Eklendi"
End Sub[/SIZE]

Hocam, ellerinize ve yüreğinize sağlık. Öncelikle ilginize ve vermiş olduğunuz yanıt için çok teşekkür ederim. Kusura bakmayın şimdi soracağım soru aslında makrolar hakkında pek bir bilgim olmamasından kaynaklı. Ben butona tıkladığımda sadece ilk iki sütunu yeni excell dosyasına atmış oluyor ancak benim ana çalışma kitabımda 10-15 sütuna kadar bilgiler yer alıyor. Birde şayet sütunların başlıklarını da yeni excell kitabına ekletebilmek için yapabileceğimiz bir şey varsa inanın tadından yenmez.

 

[byfika]

merhabalar,
Sayın PLİNT'in yazmış olduğu Kod'ta değişikle 10--15 sütunu aktarabilirsiniz.
Şu değişkliği yaparsanız istediğiniz olur.
s = s + 1
.Sheets(1).Range("A" & s & ":B" & s).Value = s1.Range("A" & b & ":B" & b).Value
Next

s = s + 1
.Sheets(1).Range("A" & s & ":O" & s).Value = s1.Range("A" & b & ":O" & b).Value
Next


Kırmızıları harfleri mavi ile yazılan harfle çevirirseniz 15 sütunu aktarırsınız.

 

[PLİNT]

Ben butona tıkladığımda sadece ilk iki sütunu yeni excell dosyasına atmış oluyor ancak benim ana çalışma kitabımda 10-15 sütuna kadar bilgiler yer alıyor. Birde şayet sütunların başlıklarını da yeni excell kitabına ekletebilmek için yapabileceğimiz bir şey varsa

Ek dosyadaki gibi deneyin, yeni oluşturulan kitapta "A:Z" sütun aralığında ki biçim ve varsa formüller korunacaktır.
http://s7.dosya.tc/server3/npcpwv/IL.zip.html

[SIZE="2"]Sub Düğme1_Tıklat()
Set s1 = ThisWorkbook.Sheets("Sayfa1")
Set ds = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\"
If ds.FolderExists(yol & "\" & "İLLER2") = False Then ds.CreateFolder yol & "\" & "İLLER2"
sat = s1.Cells(Rows.Count, 1).End(3).Row
s1.Range("A2:F" & sat).Sort Key1:=s1.Cells(2, 1), Order1:=xlAscending
s = 1
Application.ScreenUpdating = False
For a = 2 To sat
If WorksheetFunction.CountIf(s1.Range("A1:A" & a), s1.Cells(a, 1)) = 1 Then
x = WorksheetFunction.CountIf(s1.Range("A1:A" & sat), s1.Cells(a, 1))
s1.Copy
ad = s1.Cells(a, 1).Value
With ActiveWorkbook
 .ActiveSheet.DrawingObjects.Delete
 .ActiveSheet.Range("A2:B" & Rows.Count) = Empty
For b = a To a + x - 1
s = s + 1
.Sheets(1).Range("A" & s & ":B" & s).Value = s1.Range("A" & b & ":B" & b).Value
Next
.ActiveSheet.Range("A" & s & ":Z" & Rows.Count).ClearContents
.ActiveSheet.Range("A" & s & ":Z" & Rows.Count).ClearFormats
.SaveAs Filename:=yol & "İLLER2\" & ad & ".xlsx", FileFormat:=51
.Close savechanges:=True
End With
a = a + x - 1: s = 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Dosyalar Bu Kitabın Yanında oluşturulan İLLER2 Klasörü içerisine Eklendi"
End Sub
[/SIZE]

 

[deuve]

Allah razı olsun, desteğinize, elinize ve emeğinize sağlık çok teşekkür ederim. Herkese hayırlı günler dilerim.