Kritere göre klasör oluşturma

[ozuberk]

Merhaba sorum ektedir.

 

[halit3]

Merhaba sorum ektedir.

Bunu denermisiniz.

Sub ekle()
Klasor = "D:\Test\"
klasor1 = Klasor & "Alt Klasör-1\"
klasor2 = klasor1 & "Alt Klasör-2\"
klasor3 = klasor1 & "Alt Klasör-3\"
On Error Resume Next
If Dir(Klasor) = "" Then MkDir Klasor
If Dir(klasor1) = "" Then MkDir klasor1
If Dir(klasor2) = "" Then MkDir klasor2
If Dir(klasor3) = "" Then MkDir klasor3
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
On Error Resume Next
DosyaSistemi.CopyFile Klasor & "AA.xls", klasor2 & "01.12.2010 AA.xls"
DosyaSistemi.CopyFile Klasor & "BB.xls", klasor3 & "01.12.2010 BB.xls"
Application.DisplayAlerts = True
End Sub

 

[ozuberk]

Halit bey klasör isimleri yanlış oluyor. Makroyu çalıştırdığımda "Alt Klasör-1, Alt Klasör-2 ve Alt Klasör-3" adında klasör oluşturuyor. Klasörün ismi B2 de bulunan 01.12.2010, Deneme-1 ve Deneme-2" gibi olması ve devam etmesi gerekiyor. Teşekkürler

 

[halit3]

Halit bey klasör isimleri yanlış oluyor. Makroyu çalıştırdığımda "Alt Klasör-1, Alt Klasör-2 ve Alt Klasör-3" adında klasör oluşturuyor. Klasörün ismi B2 de bulunan 01.12.2010, Deneme-1 ve Deneme-2" gibi olması ve devam etmesi gerekiyor. Teşekkürler

dosyanın içindeki sorunuz aynen böyle yazıyır

1. "D:\Test" adındaki klasörün içine "Alt Klasör-1" deki kayıtlar adında klasör oluşturulacak.
2. "Alt Klasör-1" içine "Alt Klasör-2" ve "Alt Klasör-3" oluşturulacak.
"3. ""Alt Klasör-2"" içine ""D:\Test"" klasörünün içinde bulunan ""AA.xls"" adında excel sayfasını kopyalayacak ve başına ""Alt Klasör-1"" deki
ismi yazacak. Örnek. ""01.12.2010 AA.xls"" gibi"
"4. ""Alt Klasör-3"" içine ""D:\Test"" klasörünün içinde bulunan ""BB.xls"" adında excel sayfasını kopyalayacak ve başına ""Alt Klasör-1"" deki
ismi yazacak. Örnek. ""01.12.2010 AA.xls"" gibi"

 

[halit3]

bunu denermisiniz.

Sub ekle()
Klasor = "D:\Test\"
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
If Dir(Klasor) = "" Then MkDir Klasor
For i = 2 To Cells(Rows.Count, "B").End(3).Row
klasor1 = Klasor & Cells(i, 2).Value & "\"
If Dir(klasor1) = "" Then MkDir klasor1
klasor2 = klasor1 & "\" & Cells(i, 3).Value
If Dir(klasor2) = "" Then MkDir klasor2
klasor3 = klasor1 & "\" & Cells(i, 4).Value
If Dir(klasor3) = "" Then MkDir klasor3
Application.DisplayAlerts = False
On Error Resume Next
DosyaSistemi.CopyFile Klasor & "AA.xls", klasor2 & "\01.12.2010 AA.xls"
DosyaSistemi.CopyFile Klasor & "BB.xls", klasor3 & "\01.12.2010 BB.xls"
Next
Application.DisplayAlerts = True
End Sub

 

[halit3]

bunu denrmisiniz.

Sub ekle()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
For i = 2 To Cells(Rows.Count, "B").End(3).Row
On Error Resume Next
Klasor = Cells(i, 1).Value & "\"
If Dir(Klasor) = "" Then MkDir Klasor
klasor1 = Klasor & Cells(i, 2).Value & "\"
If Dir(klasor1) = "" Then MkDir klasor1
klasor2 = klasor1 & "\" & Cells(i, 3).Value
If Dir(klasor2) = "" Then MkDir klasor2
klasor3 = klasor1 & "\" & Cells(i, 4).Value
If Dir(klasor3) = "" Then MkDir klasor3
On Error Resume Next
DosyaSistemi.CopyFile Klasor & "AA.xls", klasor2 & "\" & Cells(i, 2).Value & " AA.xls"
DosyaSistemi.CopyFile Klasor & "BB.xls", klasor3 & "\" & Cells(i, 2).Value & " BB.xls"
Next
Application.DisplayAlerts = True
End Sub

 

[ozuberk]

Hocam elinize sağlık iki kodda çalışıyor. Çok teşekkür ederim. Kolay gelsin

 

[halit3]

Hocam elinize sağlık iki kodda çalışıyor. Çok teşekkür ederim. Kolay gelsin

iyi çalışmalar