Word sablon generálás
2022-06-17T12:38:27+02:00
2022-06-17T16:08:55+02:00
2022-08-12T09:30:32+02:00
Pucola
Sziasztok!

Szeretnék automatikusan generálni egy minta dokumentumból szerződést, amiben 20 db mezőt szoktunk mindig átírni, ezért csináltam egy excelt meg egy word sablont, amibe beletettem a 20 db könyvjelzőt és írtam ezt a szösszenetet:
Az a gondom, hogy lefut és ad egy teljesen üres doksit.

Private Sub asd()
 
    Dim wdApp As Word.Application
    Dim myDoc As Word.Document
    Set wdApp = New Word.Application
    With wdApp
        .Visible = False
    End With
 
   Set myDoc = wdApp.Documents.Add("C:\Users\xxx\Desktop\Ajanlatteteli_felhivas _minta.dotx")
   wdApp.ActiveDocument.Close
End Sub
 
Private Sub szerzodes()
   
    On Error GoTo errorHandler
 
    Dim fldr As FileDialog
    Dim dirStr As String
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fldr
        .Title = "Kérem válassza ki a mentés helyét!"
        .AllowMultiSelect = False
        .InitialFileName = "C:"
        If .Show <> -1 Then GoTo NextCode
        dirStr = .SelectedItems(1)
    End With
 
    
NextCode:
 
    Set fldr = Nothing
    Dim fileStr As String
    
        MsgBox ("Kérem adja meg a 'Szerződés' Word Sablon-t!")
        fileStr = Application.GetOpenFilename
    
    'Dim wdApp As Word.Application
    'Dim myDoc As Word.Document
 
    Dim Nev As Excel.Range
    Dim Szekhely As Excel.Range
    Dim Levelezes As Excel.Range
    Dim Telefon As Excel.Range
    Dim Email As Excel.Range
    Dim Kepviselo As Excel.Range
    Dim Koltseg As Excel.Range
    Dim Irany As Excel.Range
    Dim Telepules As Excel.Range
    Dim Elhelyezkedes As Excel.Range
    Dim hrsz As Excel.Range
    Dim Epitesi As Excel.Range
    Dim Gumi As Excel.Range
    Dim Veszelyes As Excel.Range
    Dim Vegyes As Excel.Range
    Dim Zold As Excel.Range
    Dim Osszesen As Excel.Range
    Dim Idoszak As Excel.Range
    Dim Elnok As Excel.Range
    
    Set wdApp = New Word.Application
    With wdApp
        .Visible = False
    End With
 
    Dim regEx As New VBScript_RegExp_55.RegExp
    
    regEx.Pattern = "^\d.*_"
    regEx.Global = True
    regEx.IgnoreCase = True
    
    Dim regExKapott As New VBScript_RegExp_55.RegExp
    
    regExKapott.Pattern = ".*Generator_sz.*"
    regExKapott.Global = True
    regExKapott.IgnoreCase = True
           
    Dim ws As Worksheet
    Dim Doc As Document
    Set Doc = wdApp.Documents.Add
    
    For Each ws In Worksheets
        If regEx.Test(ws.Name) Then
        If regExKapott.Test(ws.Name) = False Then
            If ws.Range("A1").Value = "Név" Then
                Set wdAppps = New Word.Application
                
                With wdAppps
                    .Visible = False
                End With
                Dim Docps As Document
                            
                Set Docps = wdAppps.Documents.Add
                Set myDocps = wdAppps.Documents.Add(fileStr)
                Set myDoc = wdApp.Documents.Add(fileStr)
            
                Set Nev = ws.Range("B1")
                Set Szekhely = ws.Range("B2")
                Set Levelezes = ws.Range("B3")
                Set Telefon = ws.Range("B4")
                Set Email = ws.Range("B5")
                Set Kepviselo = ws.Range("B6")
                Set Koltseg = ws.Range("B7")
                Set Irany = ws.Range("B8")
                Set Telepules = ws.Range("B9")
                Set Elhelyezkedes = ws.Range("B10")
                Set hrsz = ws.Range("B11")
                Set Epitesi = ws.Range("B12")
                Set Gumi = ws.Range("B13")
                Set Veszelyes = ws.Range("B14")
                Set Vegyes = ws.Range("B15")
                Set Zold = ws.Range("B16")
                Set Osszesen = ws.Range("B17")
                Set Idoszak = ws.Range("B18")
                Set Kelt = ws.Range("B19")
                Set Elnok = ws.Range("B20")
                
                If IsNumeric(BB) Then
                    With myDoc.Bookmarks
                        .Item("B1").Range.InsertAfter B1
                        .Item("B2").Range.InsertAfter B2
                        .Item("B3").Range.InsertAfter B3
                        .Item("B4").Range.InsertAfter B4
                        .Item("B5").Range.InsertAfter B5
                        .Item("B6").Range.InsertAfter B6
                        .Item("B7").Range.InsertAfter B7
                        .Item("B8").Range.InsertAfter B8
                        .Item("B9").Range.InsertAfter B9
                        .Item("B10").Range.InsertAfter B10
                        .Item("B11").Range.InsertAfter B11
                        .Item("B12").Range.InsertAfter B12
                        .Item("B13").Range.InsertAfter B13
                        .Item("B14").Range.InsertAfter B14
                        .Item("B15").Range.InsertAfter B15
                        .Item("B16").Range.InsertAfter B16
                        .Item("B17").Range.InsertAfter B17
                        .Item("B18").Range.InsertAfter B18
                        .Item("B19").Range.InsertAfter B19
                        .Item("B20").Range.InsertAfter B20
                        
                    End With
                    
                    With myDocps.Bookmarks
                        .Item("B1").Range.InsertAfter B1
                        .Item("B2").Range.InsertAfter B2
                        .Item("B3").Range.InsertAfter B3
                        .Item("B4").Range.InsertAfter B4
                        .Item("B5").Range.InsertAfter B5
                        .Item("B6").Range.InsertAfter B6
                        .Item("B7").Range.InsertAfter B7
                        .Item("B8").Range.InsertAfter B8
                        .Item("B9").Range.InsertAfter B9
                        .Item("B10").Range.InsertAfter B10
                        .Item("B11").Range.InsertAfter B11
                        .Item("B12").Range.InsertAfter B12
                        .Item("B13").Range.InsertAfter B13
                        .Item("B14").Range.InsertAfter B14
                        .Item("B15").Range.InsertAfter B15
                        .Item("B16").Range.InsertAfter B16
                        .Item("B17").Range.InsertAfter B17
                        .Item("B18").Range.InsertAfter B18
                        .Item("B19").Range.InsertAfter B19
                        .Item("B20").Range.InsertAfter B20
                        
                        End With
 
                End If
 
                wdApp.Selection.WholeStory
                wdApp.Selection.Copy
                wdApp.ActiveWindow.Close False
                Doc.Activate
                wdApp.Selection.PasteAndFormat (wdFormatOriginalFormattig)
                
                wdAppps.Selection.WholeStory
                wdAppps.Selection.Copy
                wdAppps.ActiveWindow.Close False
                Docps.Activate
                wdAppps.Selection.PasteAndFormat (wdFormatOriginalFormattig)
                wdAppps.ActiveDocument.SaveAs dirStr & "" & ws.Name
                wdAppps.ActiveDocument.Close
                
            End If
        End If
        End If
    Next ws
    
    wdApp.ActiveDocument.SaveAs dirStr & "Szerződés " & Format(Date, "yyyymmdd")
    wdApp.ActiveDocument.Close
    MsgBox ("Generálás kész! [" & dirStr & "Szerződés " & Format(Date, "yyyymmdd") & "]")
    GoTo exitHandler
    
errorHandler:
MsgBox ("Error # " & Err & " " & ws.Name & " : " & Error(Err))
Set wdApp = Nothing
exitHandler:
    Set wdApp = Nothing
End Sub
Mutasd a teljes hozzászólást!

abcd