Hücrelerden alacağı isimle klasör oluşturma

[tahsinanarat]

Sub Mutabakat_hazirlapdf()
Dim Uzlasma As Word.Document

Set R1 = ThisWorkbook.Worksheets("Satıcılar_Mizan")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Mutabakatlar\saticilar_pdf\"

sablon = ThisWorkbook.Path & "\Şablon\Mutabakat_saticilar.docx"

kaydet2 = ThisWorkbook.Path & "\Mutabakatlar\"
kaydet1 = ThisWorkbook.Path & "\Mutabakatlar\saticilar_pdf\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1

Set msword = CreateObject("word.application")
msword.Visible = True

For i = 6 To sonsatir
Set Uzlasma = msword.Documents.Open(Filename:=sablon, ReadOnly:=True)
'TAŞINMAZ SATIRLARI
Uzlasma.Bookmarks("Firma").Range = R1.Cells(i, "B").Text         'Satıcı Firma adı
Uzlasma.Bookmarks("Tarih").Range = R1.Range("b2").Text           'ilgili ay tarih sonu
Uzlasma.Bookmarks("Bakiye").Range = R1.Cells(i, "E").Text * -1        'Bakiye
Uzlasma.Bookmarks("ay").Range = R1.Range("c2").Text              'ilgili tarihin ayı
Uzlasma.Bookmarks("ay2").Range = R1.Range("c2").Text             'ilgili tarihin ayı

DosyaAdi = R1.Range("E2").Text & "-" & R1.Range("D2").Text & " " & R1.Cells(i, "B") & " MUTABAKAT"
MyArray = Array("<", ">", "|", "/", " / ", "*", ":", "\", " \ ", ".", "?", """")
For x = LBound(MyArray) To UBound(MyArray)
    DosyaAdi = Replace(DosyaAdi, MyArray(x), "_", 1)
Next x
dosyayol = yoll & DosyaAdi & ".pdf"
'Uzlasma.SaveAs dosyayol

    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        dosyayol _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForOnScreen, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    ShowVisualBasicEditor = True

Uzlasma.Close 0
Next i
msword.Quit
MsgBox "işlem tamam"
End Sub

Yukarıdaki kod ile mutabakat için b sutununda bulunan isimler için C:\Users\tomson\Desktop\Tomson_deneme\Mutabakatlar\saticilar_pdf klasörü içerisinde ayrı ayrı pdf dosyası oluşturabiliyorum.

Ancak ben saticilar_pdf klasörü içerisinde D2 ve E2 hücrelerinden alacağı Yani 2022 MART olarak bir klasör daha oluşturup bu klasörün içine kaydetmek istedim ki, ayları ayrı ayrı klasörlerde takip edebilmek için, ancak başarılı olamadım. Bu konuda hocalarımdan desdek beklemekteyim.

Yardımlarınız için şimdiden teşükkür ederim.
Saygılar.

Not : Dosyam daha evvelce bu siteden temin ettiğim kodlardan faylanarak yapılmıştır.

 

[tahsinanarat]

Konu günceldir

 

[necati]

Merhaba,

Sub Mutabakat_hazirlapdf()
'
Dim Uzlasma As Word.Document


Set R1 = ThisWorkbook.Worksheets("Satıcılar_Mizan")
sonsatir = R1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
yoll = ThisWorkbook.Path & "\Mutabakatlar\saticilar_pdf\"

sablon = ThisWorkbook.Path & "\Şablon\Mutabakat_saticilar.docx"

kaydet2 = ThisWorkbook.Path & "\Mutabakatlar\"
'kaydet1 = ThisWorkbook.Path & "\Mutabakatlar\saticilar_pdf\"
kaydet1 = ThisWorkbook.Path & "\Mutabakatlar\saticilar_pdf\" & R1.Range("E2").Text & "-" & R1.Range("D2").Text & "\"

If Len(Dir(kaydet2, vbDirectory)) = 0 Then MkDir kaydet2
If Len(Dir(kaydet1, vbDirectory)) = 0 Then MkDir kaydet1


Set msword = CreateObject("word.application")
msword.Visible = True

For i = 6 To sonsatir
Set Uzlasma = msword.Documents.Open(Filename:=sablon, ReadOnly:=True)
'TAŞINMAZ SATIRLARI
Uzlasma.Bookmarks("Firma").Range = R1.Cells(i, "B").Text         'Satıcı Firma adı
Uzlasma.Bookmarks("Tarih").Range = R1.Range("b2").Text           'ilgili ay tarih sonu
Uzlasma.Bookmarks("Bakiye").Range = R1.Cells(i, "E").Text * -1        'Bakiye
Uzlasma.Bookmarks("ay").Range = R1.Range("c2").Text              'ilgili tarihin ayı
Uzlasma.Bookmarks("ay2").Range = R1.Range("c2").Text             'ilgili tarihin ayı

DosyaAdi = R1.Range("E2").Text & "-" & R1.Range("D2").Text & " " & R1.Cells(i, "B") & " MUTABAKAT"
MyArray = Array("<", ">", "|", "/", " / ", "*", ":", "\", " \ ", ".", "?", """")
For x = LBound(MyArray) To UBound(MyArray)
    DosyaAdi = Replace(DosyaAdi, MyArray(x), "_", 1)
Next x
'dosyayol = yoll & DosyaAdi & ".pdf"
dosyayol = kaydet1 & DosyaAdi & ".pdf"
'Uzlasma.SaveAs dosyayol

    Uzlasma.ExportAsFixedFormat OutputFileName:=dosyayol _
        , ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    'ShowVisualBasicEditor = True

Uzlasma.Close 0
Next i
msword.Quit
Set R1 = Nothing
Set Uzlasma = Nothing
Set msword = Nothing
MsgBox "işlem tamam"
End Sub

 

[tahsinanarat]

Sn. @necati eve geçtiğimde deneyeceğim, iş yerimdeki pc de bu kodu (benim kod dahil) çalıştırdığımda Run time error 6124 "Korumalı olduğundan bu seçimi düzenleme izniniz yok" hatası alıyorum, bu hatanın denenini gün boyunca araştırdım ancak bulamadım. Evde denediğimde sonuçtan bilgi vereceğim. Cevabınız için çok teşekkür ediyorum. Saygılar

 

[necati]

Şablon olarak kullandığınız word belgesinde herhangi bir sayfa koruması, düzenleme izin kısıtlaması falan yaptıysanız, bu hatayı almış olabilirsiniz diye düşünüyorum.

 

[tahsinanarat]

Sn. @necati Bey kodları evde denedim herhangi bir sıkıntı yok, tekrardan teşekkürler.