vba hücreden klasör ismi

[kalibre101]

merhabalar klasör oluşturmak istiyorum
D sürücüsü varsa D ye yoksa C sürücüsü içine
Personel isimli klasör oluşturup içinede
çalışma kitabımın sayfa indeksi 1 olan M9 hücresindeki isimle klasör oluşturup
onun içinede yine sayfa indeksi 1 olan M16 hücresindeki tarihle klasör oluşturup
sayfa 1 i içine kopyalayıp içindeki nesneleride silecek
yardımcı olursanız çok sevinirim
ben kendim klasör oluşturabiliyorum fakat hücredeki isimleri ve tarihleri klasöre isim olarak veremedim.

 

[uzmanamele]

Merhaba
Kullandığınız kodu paylaşırsanız daha çabuk sonuça ulaşırsınz.
Bu şekilde sipariş vermek gibi oluyor.

 

[kalibre101]

Merhaba
Kullandığınız kodu paylaşırsanız daha çabuk sonuça ulaşırsınz.
Bu şekilde sipariş vermek gibi oluyor.

Sub İZİN_FORMU_AKTAR()
Dim kyt As String, yol As String, yol2 As String, yol3 As String, hcr As String, WB As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

hcr = Sheets(1).[M9].Value
trh = Format(Sheets(1).Range("M16"), "yyyy")


yol2 = "D:\"
yol = "C:\Personel\hcr\trh\"
yol3 = "D:\Personel\hcr\trh\"

If Dir(yol2, vbDirectory) = "" Then
If Dir("C:\Personel\", vbDirectory) = "" Then MkDir "C:\Personel\"
If Dir("C:\Personel\hcr\", vbDirectory) = "" Then MkDir "C:\Personel\hcr\"
If Dir("C:\Personel\hcr\trh\", vbDirectory) = "" Then MkDir "C:\Personel\hcr\trh\"
Else
If Dir("D:\Personel\", vbDirectory) = "" Then MkDir "D:\Personel\"
If Dir("D:\Personel\hcr\", vbDirectory) = "" Then MkDir "D:\Personel\hcr\"
If Dir("D:\Personel\hcr\trh\", vbDirectory) = "" Then MkDir "D:\Personel\hcr\trh\"
End If

ThisWorkbook.Unprotect "123"
kyt = "hcr" & " " & "Yıllık izin formu" & " .xlsx"

If Dir(yol2, vbDirectory) = "" Then
ThisWorkbook.Sheets("İZİN FORMU").Copy
ActiveWorkbook.SaveAs yol & kyt
Application.Wait (Now + TimeValue("0:00:01"))
Set WB = Workbooks.Open(yol & kyt)
With WB.Sheets(1)
.Unprotect "2227"
.DrawingObjects.Delete
ActiveWorkbook.Save
End With
Else
ThisWorkbook.Sheets("İZİN FORMU").Copy
ActiveWorkbook.SaveAs yol3 & kyt
Set WB = Workbooks.Open(yol3 & kyt)
With WB.Sheets(1)
.Unprotect "2227"
.DrawingObjects.Delete
ActiveWorkbook.Save
End With

End If
ActiveWorkbook.Close
MsgBox "İZİN FORMU AKTARILDI", vbApplicationModal, "NURETTİN KOÇAK"
Application.ScreenUpdating = True
kyt = "": yol = "": yol2 = "": yol3 = "": hcr = "": Set WB = Nothing
End Sub

 

[kalibre101]

Sub İZİN_FORMU_AKTAR()
Dim kyt As String, yol As String, yol2 As String, yol3 As String, hcr As String, WB As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

hcr = Sheets(1).[M9].Value
trh = Format(Sheets(1).Range("M16"), "yyyy")


yol2 = "D:\"
yol = "C:\Personel\hcr\trh\"
yol3 = "D:\Personel\hcr\trh\"

If Dir(yol2, vbDirectory) = "" Then
If Dir("C:\Personel\", vbDirectory) = "" Then MkDir "C:\Personel\"
If Dir("C:\Personel\hcr\", vbDirectory) = "" Then MkDir "C:\Personel\hcr\"
If Dir("C:\Personel\hcr\trh\", vbDirectory) = "" Then MkDir "C:\Personel\hcr\trh\"
Else
If Dir("D:\Personel\", vbDirectory) = "" Then MkDir "D:\Personel\"
If Dir("D:\Personel\hcr\", vbDirectory) = "" Then MkDir "D:\Personel\hcr\"
If Dir("D:\Personel\hcr\trh\", vbDirectory) = "" Then MkDir "D:\Personel\hcr\trh\"
End If

ThisWorkbook.Unprotect "123"
kyt = "hcr" & " " & "Yıllık izin formu" & " .xlsx"

If Dir(yol2, vbDirectory) = "" Then
ThisWorkbook.Sheets("İZİN FORMU").Copy
ActiveWorkbook.SaveAs yol & kyt
Application.Wait (Now + TimeValue("0:00:01"))
Set WB = Workbooks.Open(yol & kyt)
With WB.Sheets(1)
.Unprotect "2227"
.DrawingObjects.Delete
ActiveWorkbook.Save
End With
Else
ThisWorkbook.Sheets("İZİN FORMU").Copy
ActiveWorkbook.SaveAs yol3 & kyt
Set WB = Workbooks.Open(yol3 & kyt)
With WB.Sheets(1)
.Unprotect "2227"
.DrawingObjects.Delete
ActiveWorkbook.Save
End With

End If
ActiveWorkbook.Close
MsgBox "İZİN FORMU AKTARILDI", vbApplicationModal, "NURETTİN KOÇAK"
Application.ScreenUpdating = True
kyt = "": yol = "": yol2 = "": yol3 = "": hcr = "": Set WB = Nothing
End Sub

sorunum klasör isimlerini hcr ve trh diye atıyor bunun yerine tanımladığım hücreleri atmasını istiyorum
teşekkür ederim

 

[kalibre101]

Sorunu aşağıdaki kodla çözdüm teşekkürler

Sub İZİN_FORMU_AKTAR()
Dim FSO As Object, My_Date As Date, My_Path As String
Dim My_Driver As String, My_Folder As String
Dim My_File As String, X As Byte, kyt As String, hcr As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set FSO = CreateObject("Scripting.FileSystemObject")
kyt = hcr & " " & Format(Sheets(1).Range("M16"), "mmmm yyyy") & " " & "Yıllık izin formu" & " .xlsx"
hcr = Sheets(1).Range("M36")
My_Date = Sheets(1).Range("M16").Value
My_Path = "Personel\"

If FSO.DriveExists("D:\") = True Then
My_Driver = "D:\"
ElseIf FSO.DriveExists("C:\") = True Then
My_Driver = "C:\"
Else
MsgBox "İşlem yapabileciğiniz sürücü bulunamadı!", vbCritical
Exit Sub
End If

My_Folder = My_Driver & My_Path & hcr & "\" & Year(My_Date) & "\"

If Len(Dir(My_Folder, vbDirectory)) = 0 Then
Shell ("cmd /c mkdir """ & My_Folder & """")
End If
ThisWorkbook.Sheets("İZİN FORMU").Copy
ActiveWorkbook.SaveAs My_Folder & kyt
Application.Wait (Now + TimeValue("0:00:01"))
Set WB = Workbooks.Open(My_Folder & kyt)
With WB.Sheets(1)
.Unprotect "2227"
.DrawingObjects.Delete
ActiveWorkbook.Save
ActiveWorkbook.Close
End With
Set FSO = Nothing: My_Path = "": My_Driver = "": My_Folder = "": My_File = "": kyt = "": hcr = "": X = 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "YILLIK İZİN FORMU AKTARILDI", vbInformation, "NURETTİN KOÇAK"
End Sub