Makro birleştirmek

[metin_0606]

1. KOD
Sub Klasor_Olustur()

Dim Yedek_Dosya_Adı As String, Kayıt_Yeri As String
yol = "C:\ZİMMET\"
For i = 1 To Range("D3").End(xlUp).Row
klasor = yol & Cells(i, 4).Value
On Error Resume Next
MkDir klasor
On Error GoTo 0
Next
End Sub
*******************************************************
2.KOD
Sub farklıkaydetPDF()
dosya_adı = Cells(3, "D").Value & Format(Now, " ddmmyyyy_hhnn")
If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
Kaynak = "C:\ZİMMET\"
If Right(Kaynak, 1) <> "\" Then
End If
yer = Kaynak & dosya_adı
Range("A1:e30").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yer, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

1. Makro ile Zimmet klasörünün içerisine D3 hücresinden isim alarak klasör oluşturuyorum. 2. Makro ile ise cells(3,"D") den ismini alarak Zimmet klasörünün içerisine Formu PDF olarak kaydediyorum. Benim yapmak istediğim. 1. Makro ile aynı şekilde klasör açıp 2. makro ile de 1. makronun açtığı klasörün içerisine PDf olarak yine aynı yerden yani cells(3,"D") den ismini ve güncel kayıt tarihini alarak PDF olarak kaydetmek istiyorum. Yardımlarınız için şimdiden teşekkürler

 

[PLİNT]

Merhaba
Aşağıdaki gibi birleştirilebilir

Sub farklıkaydetPDF()
Dim dosya_adı As String, yer As String, ds
If Trim(Cells(3, "D").Value) = "" Then MsgBox "[D3] e AD yazınız": Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
If ds.FolderExists("C:\ZİMMET") = False Then MkDir "C:\ZİMMET"
If ds.FolderExists("C:\ZİMMET\" & Cells(3, "D").Value) = False Then MkDir "C:\ZİMMET\" & Cells(3, "D").Value
dosya_adı = Cells(3, "D").Value & Format(Now, " ddmmyyyy_hhnn")
yer = "C:\ZİMMET\" & Trim(Range("D3").Value) & "\" & dosya_adı
Range("A1:E30").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yer, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

 

[metin_0606]

Merhaba
Aşağıdaki gibi birleştirilebilir

Sub farklıkaydetPDF()
Dim dosya_adı As String, yer As String, ds
If Trim(Cells(3, "D").Value) = "" Then MsgBox "[D3] e AD yazınız": Exit Sub
Set ds = CreateObject("Scripting.FileSystemObject")
If ds.FolderExists("C:\ZİMMET") = False Then MkDir "C:\ZİMMET"
If ds.FolderExists("C:\ZİMMET\" & Cells(3, "D").Value) = False Then MkDir "C:\ZİMMET\" & Cells(3, "D").Value
dosya_adı = Cells(3, "D").Value & Format(Now, " ddmmyyyy_hhnn")
yer = "C:\ZİMMET\" & Trim(Range("D3").Value) & "\" & dosya_adı
Range("A1:E30").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yer, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Sayın plint hocam çok teşekkürler kod istenildiği gibi çalışıyor