Soru Klasör oluşturup, word dosyalarını içine kaydetmek

[mkarakas_58]

Private Sub CommandButton1_Click()
    Dim Doc As Word.Document
    Dim WordApp As Word.Application
    Dim Sablon As String
    Dim i As Integer
    Sablon = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\"
MkDir ("MEK DENETİM RAPORLARI")

    Set WordApp = New Word.Application
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    Set Doc = WordApp.Documents.Open(Sablon & "MEK.docx")
        Doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
        Doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
        Doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
        Doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
        Doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
        Doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
        Doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
        
        Doc.SaveAs2 Sablon & Cells(i, 3).Text
    Doc.Close
    Next
 
    WordApp.Quit
    MsgBox "Tamamlandı.", vbExclamation
End Sub

Merhaba üstadlar, masaüstündeki MEK.docx açıyor, koddaki döngüyü yapıyor ve masaüstüne word dosyasını tek tek kaydediyor. Tamam buraya kadar üstadlar saolsunlar yardım ettiler.

Lakin çok dosya oluşturmakda, masaüstü çöplük oluyor. Ben bir klasör oluşturdum. MEK DENETİM KLASÖRÜ bu yeni oluşturduğum klasörün içine word dosyalarını kaydetmesini istiyorum.

Hatta yapabilirsek a1 hücresindeki metindeki değerde klasör oluşturulup içine kaydetsin. Her kullanımda farklı klasör olmasıda işimizi kolaylaştırır.

Nasıl yapabiliriz.

 

[muhasebeciyiz]

Private Sub CommandButton1_Click()
    Dim Doc As Word.Document
    Dim WordApp As Word.Application
    Dim DesktopPath As String
    Dim NewFolderPath As String
    Dim FolderName As String
    Dim i As Integer
    
    DesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
    
    FolderName = Cells(1, "A").Value
    
    If FolderName = "" Then
        FolderName = "MEK Denetim Raporları"
    End If
    
    NewFolderPath = DesktopPath & FolderName & "\"
    
    If Dir(NewFolderPath, vbDirectory) = "" Then
        MkDir NewFolderPath
    End If
    
    Set WordApp = New Word.Application
    
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        Set Doc = WordApp.Documents.Open(DesktopPath & "MEK.docx")
        
        Doc.Bookmarks("protokoltarih").Range.InsertAfter Cells(i, 10)
        Doc.Bookmarks("protokolno").Range.InsertAfter Cells(i, 9)
        Doc.Bookmarks("meslek").Range.InsertAfter Cells(i, 3)
        Doc.Bookmarks("kursadı").Range.InsertAfter Cells(i, 4)
        Doc.Bookmarks("firma").Range.InsertAfter Cells(i, 5)
        Doc.Bookmarks("bitis").Range.InsertAfter Cells(i, 12)
        Doc.Bookmarks("baslama").Range.InsertAfter Cells(i, 11)
        
        Doc.SaveAs2 NewFolderPath & Cells(i, 3).Text & ".docx"
        
        Doc.Close
    Next i
    
    WordApp.Quit
    
    MsgBox "İşlem başarıyla tamamlandı. Dosyalar '" & FolderName & "' klasörüne kaydedildi.", vbExclamation
End Sub

her çalıştırmada A1 hücresindeki isme göre dinamik olarak yeni bir klasör oluşturulacak ve tüm Word dosyaları o klasörün içine kaydedilecektir. Böylece masaüstünüz düzenli kalacaktır.