Dosya oluşturma

[ASLAN7410]

Merhaba hayırlı akşamlar.

Masa üzerinde İSİMLER adlı bir excel sayfam var, bu sayfanın A sütununda A2'den a ile A1000 arasındaki hücrelerde isimler var.

Benim istediğim masa üstüne ÇALIŞMA diye bir klasör oluşturup bu klasör içerisine A2 ile A1000 arasındaki isimlere göre excel sayfası oluşturmasını istiyorum.

Forumda ve internette araştırdım bu şekilde bir çalışma bulamadım.

Yardımcı olur musunuz?

 

[PLİNT]

Merhaba
Dosyanızı görme imkanım yok ama; sanırım istediğiniz aşağıdaki gibi bir kod;

[SIZE="2"]Private Sub CommandButton1_Click()
Dim r, a, f
Dim s As Long
Dim m As Integer
'On Error Resume Next
Set r = CreateObject("wscript.Shell")
Set a = CreateObject("scripting.filesystemobject")
Set f = a.GetFolder(r.SpecialFolders.Item("Desktop") & Application.PathSeparator)
If a.FolderExists(f & "\" & "ÇALIŞMA") = False Then _
MkDir r.SpecialFolders.Item("Desktop") & Application.PathSeparator & "ÇALIŞMA"
Application.ScreenUpdating = False
If a.FileExists(f & "\ÇALIŞMA\" & Cells(2, 1) & ".xlsx") = False Then
Workbooks.Add
Dosya = f & "\ÇALIŞMA\" & Cells(2, 1) & ".xlsx"
ActiveWorkbook.SaveAs Dosya
ActiveWorkbook.Close savechanges:=False
m = m + 1
End If
Application.ScreenUpdating = True
For s = 3 To 1000
If Cells(s, 1) <> "" Then
If a.FileExists(f & "\ÇALIŞMA\" & Cells(s, 1) & ".xlsx") = False Then
FileCopy Dosya, f & "\ÇALIŞMA\" & Cells(s, 1) & ".xlsx"
m = m + 1
End If: End If
Next
MsgBox m & " ADET DOSYA OLUŞTURULDU"
End Sub[/SIZE]

 

[ASLAN7410]

Sayın PLİNT ilginiz için çok teşekkür ediyorum. Dosyayı aşağıdaki linke yükledim.

http://dosya.co/avtnq19t94no/İSİMLER.xlsm.html

Masa üzerinde bulunan İSİMLER isimli dosyama yazmış olduğunuz kodu uyguladığımda
aşağıdaki resimdeki gibi hata mesajı veriyor. Klasör oluşuyor ancak excel sayfaları oluşmuyor.

http://dosya.co/0pxa6x8jfe7g/Adsız.jpg.html


Kodda bu kısmı sarıya boyuyor. ActiveWorkbook.SaveAs Dosya

 

[PLİNT]

Merhaba
Düşündüğüm sayfaya ekleyeceğiniz "Commandbutton" altında kullanmanızdı;
Modül de şöyle eklemeler, hatayı kaldıracaktır.

Sub DosyaOluştur()
Dim r, a, f
Dim s As Long
Dim m As Integer
[COLOR="Red"]Dim s1 As Worksheet
Set s1 = ThisWorkbook.Sheets("Sayfa1")[/COLOR]
'On Error Resume Next
Set r = CreateObject("wscript.Shell")
Set a = CreateObject("scripting.filesystemobject")
Set f = a.GetFolder(r.SpecialFolders.Item("Desktop") & Application.PathSeparator)
If a.FolderExists(f & "\" & "ÇALIŞMA") = False Then _
MkDir r.SpecialFolders.Item("Desktop") & Application.PathSeparator & "ÇALIŞMA"
Application.ScreenUpdating = False
If a.FileExists(f & "\ÇALIŞMA\" & [COLOR="Red"]s1.[/COLOR]Cells(2, 1) & ".xlsx") = False Then
Workbooks.Add
Dosya = f & "\ÇALIŞMA\" & [COLOR="Red"]s1.[/COLOR]Cells(2, 1) & ".xlsx"
ActiveWorkbook.SaveAs Dosya
ActiveWorkbook.Close savechanges:=False
m = m + 1
End If
Application.ScreenUpdating = True
For s = 3 To 1000
If [COLOR="Red"]s1.[/COLOR]Cells(s, 1) <> "" Then
If a.FileExists(f & "\ÇALIŞMA\" & [COLOR="Red"]s1.[/COLOR]Cells(s, 1) & ".xlsx") = False Then
FileCopy Dosya, f & "\ÇALIŞMA\" & [COLOR="Red"]s1.[/COLOR]Cells(s, 1) & ".xlsx"
m = m + 1
End If: End If
Next
MsgBox m & " ADET DOSYA OLUŞTURULDU"
End Sub

 

[ASLAN7410]

Sayın PLİNT ellerinize sağlık tam istediğim gibi oldu, Allah razı olsun.

Hayırlı geceler hayırlı çalışmalar dilerim.