VBA EXCEL 2010 - Opret seperate PDF dokumenter i WORD skabelon med værdoer fra EXCEL regneark
Jeg sidder i øjeblikket med et problem, hvor jeg skal flette værdier fra et EXCEL regneark ind i en WORD skabelon, og for hver række i regnearket skal jeg gemme det dannede dokument som som en PDF fil med navn fra en kolonne i regnearket.Jeg har lavet følgende kode:
Sub Makro1()
'
' Makro1 Makro
'
' Genvejstast:Ctrl+m
'
Dim Wdapp As Object
On Error Resume Next
Set Wdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set Wdapp = CreateObject("Word.Application")
End If
Cells(1, 2).Select
liste = Selection.Text
lengde = Len(liste)
For i = lengde To 2 Step -1
If Mid(liste, i, 1) = "\" Then
ldir = Left(liste, i - 1)
lark = Right(liste, lengde - i)
i = 1
End If
Next
ChDir ldir
Workbooks.Open Filename:=liste
Cells(2, 1).Select
srk = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
For w = 2 To srk
Cells(w, 1).Select
a = Selection.Text
Cells(w, 2).Select
b = Selection.Text
Cells(w, 3).Select
c = Selection.Text
Cells(w, 4).Select
d = Selection.Text
Cells(w, 5).Select
e = Selection.Text
Cells(w, 6).Select
f = Selection.Text
Cells(w, 7).Select
g = Selection.Text
Cells(w, 8).Select
h = Selection.Text
Cells(w, 9).Select
i = Selection.Text
Cells(w, 10).Select
j = Selection.Text
Wdapp.Documents.Add "K:\Afd\SALG\HCS\TEST.dotx"
Wdapp.Visible = True
Wdapp.ActiveDocument.Bookmarks("A").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=a
Wdapp.ActiveDocument.Bookmarks("B").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=b
Wdapp.ActiveDocument.Bookmarks("C").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=c
Wdapp.ActiveDocument.Bookmarks("D").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=d
Wdapp.ActiveDocument.Bookmarks("E").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=e
Wdapp.ActiveDocument.Bookmarks("F").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=f
Wdapp.ActiveDocument.Bookmarks("G").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=g
Wdapp.ActiveDocument.Bookmarks("H").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=h
Wdapp.ActiveDocument.Bookmarks("I").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=i
Wdapp.ActiveDocument.Bookmarks("J").Select
Wdapp.Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Wdapp.Selection.TypeText Text:=j
doknavn = ldir & "\" & a & ".pdf"
Wdapp.ChangeFileOpenDirectory ldir
Wdapp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
doknavn, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, CreateBookmarks:= _
wdExportCreateNoBookmarks, DocStructureTags:=True, BitmapMissingFonts:= _
True, UseISO19005_1:=False
Wdapp.ChangeFileOpenDirectory ldir
Wdapp.ActiveWindow.Close
Next
Wdapp.Quit
Set Wdapp = Nothing
MsgBox "Fletningen er færdig." & vbCrLf & srk - 1 & " dokumneter er blevet dannet", _
vbOKOnly + vbInformation
End Sub
Selve åbningen af WORD skabelonen og indsættelse af værdierne de rigtige steder går godt. Men når så skal gemme dokumentet som en PDF fil, så spinger den dette step over uden at der kommer nogen form for fejlmeddelelse eller anden indikation af, at VBA ikke forstår statementet, som jeg i øvrigt har fået til at fungere i en WORD makro.
Jeg kører på Windows XP med Office 2010.
