我正在构建一个Excel-Tool,你将拥有一个输入掩码。完成并单击“执行”后,它将通过预定义的文本标记自动从模板创建包含worddocuments的目录。现在问题:
在这些模板中是表格,我只想给这些表格提供他们真正需要的那么多行,我完全不知道如何解决这个问题。在下面找到自动填写的代码:
Public Function Txtmkr_SDD()
Dim appWord As Object 'Word-Instance
Dim wdDoc As Object 'Word-Document
Dim wdRngE As Object 'Word-Range 1
Dim wdRngR As Object 'Word-Range 2
Dim wdRngC As Object 'Word-Range 3
Dim wdRngCN As Object 'Word-Range 4
Dim wks As Worksheet 'Excel-Worksheet
Dim AdresseCE As String
Dim neueAdresseCE As Long
Dim Processname1 As String
Dim Processname2 As String
Dim Version As String
Dim IDPath As String
If TB_ID.Value = vbNullString Then TB_ID = IDPath Else IDPath = (TB_ID.Value) & Chr(32)
'*** Word start ***
Set appWord = CreateObject("Word.Application")
'*** opens File ***
Set wdDoc = appWord.Documents.Add(Template:=Worksheets("StartPage").Cells(48, 4) & "\Document_Templates\SDD_Template.dotx", NewTemplate:=False, DocumentType:=0)
'*** Word visible ***
appWord.Visible = True
'*** just in case Document is protected ***
'doc.Unprotect
'*** Jump to Textmarker in Word ***
'*** Check of existence ***
'*** Take Value from "CopyData" Cell "B1" and insert Textmarker ***
If wdDoc.Bookmarks.Exists("Processname1") Then
With wdDoc.Bookmarks("Processname1")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(1, 2).Value
wdDoc.Bookmarks.Add "Processname1", wdRngE
End With
Else
MsgBox "Missing Link [Processname1]."
End If
'*** Take Value from "CopyData" Cell "B2" and insert Textmarker ***
If wdDoc.Bookmarks.Exists("Processname2") Then
With wdDoc.Bookmarks("Processname2")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(2, 2).Value
wdDoc.Bookmarks.Add "Processname2", wdRngE
End With
Else
MsgBox "Missing Link [Processname2]."
End If
If wdDoc.Bookmarks.Exists("SDDVersion") Then
With wdDoc.Bookmarks("SDDVersion")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(3, 2).Value
wdDoc.Bookmarks.Add "SDDVersion", wdRngE
End With
Else
MsgBox "Missing Link [Version]."
End If
If wdDoc.Bookmarks.Exists("Create_Date") Then
With wdDoc.Bookmarks("Create_Date")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(4, 2).Value
wdDoc.Bookmarks.Add "Create_Date", wdRngE
End With
Else
MsgBox "Missing Link [Create_Date]."
End If
If wdDoc.Bookmarks.Exists("SDDAuthor") Then
With wdDoc.Bookmarks("SDDAuthor")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(6, 2).Value
wdDoc.Bookmarks.Add "SDDAuthor", wdRngE
End With
Else
MsgBox "Missing Link [Author]."
End If
If wdDoc.Bookmarks.Exists("ProcessID") Then
With wdDoc.Bookmarks("ProcessID")
Set wdRngE = .Range
wdRngE.Text = Worksheets("CopyData").Cells(20, 2).Value
wdDoc.Bookmarks.Add "ProcessID", wdRngE
End With
Else
MsgBox "Missing Link [Author]."
End If
'*** Set Time_Date and SDD Path ***
Dim time_date As String
time_date = Format(Date, "yyyy_mm_dd")
Dim SDD As String
Dim shp As Shape
'*** Define SDD as Filename ***
SDD = (time_date & "_" & Worksheets("CopyData").Cells(1, 2).Value & "_" & Worksheets("CopyData").Cells(21, 2).Value & "_" & Worksheets("Helper#3").Cells(3, 2).Value & "_" & "V" & Worksheets("CopyData").Cells(3, 2).Value & ".docx")
'*** Dim wdApp As Word.Application ***
Set wdApp = GetObject(, "Word.Application")
'*** Set up SavePath & Filename ***
appWord.ActiveDocument.SaveAs Worksheets("Variables").Cells(3, 8).Value & "\" & IDPath & (Worksheets("Setup#2_DirectoryList").Cells(1, 1)) & "\" & Worksheets("Setup#2_DirectoryList").Cells(3, 3).Value & "\" & Worksheets("Setup#2_DirectoryList").Cells(14, 21).Value & "\" & SDD
'*** Updates the Footer in Word ans saves the file ***
Application.ScreenUpdating = True
With appWord.ActiveDocument
.Fields.Update
.PrintPreview
.ClosePrintPreview
Application.ScreenUpdating = True
appWord.ActiveDocument.Save
For Each shp In doc.Shapes
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
Next
End With
'*** Word quit ***
appWord.ActiveDocument.Close
appWord.Quit
'*** set Variables free ***
Set wdRngE = Nothing
Set wdRngR = Nothing
Set wdRngC = Nothing
Set wdRngCN = Nothing
Set wdRng = Nothing
Set wdDoc = Nothing
Set appWord = Nothing
Set sFolder = Nothing
End Function
对于普通的文本标记,这个应用程序正常工作,但现在我需要动态表,因为即使输入可能为内容提供20行 - 它也不能在最终的worddocument中完全填充。
如果有人知道如何做到这一点会很好。
除此之外:thx Harassed Dad进行编辑;-)
为了进一步的要求;这就是它目前的样子(宏运行的excel表)
Excel-Tool with Macro The Macro needs to give more rows if there are indeed 10 Credential-Entries, but there should also be only 3, 4 etc, so i am looking for a way to add them dynamically
Sub test()
Dim WA As Object, WD As Object
TempFolder = ThisWorkbook.path & "\Temp\"
TemplateName = ThisWorkbook.path & "\file.docx"
Set WA = CreateObject("Word.Application")
'WA.Visible = False
Set WD = WA.Documents.Add(TemplateName)
With WD
If IsBM(WD, "Table_Info") Then ' Check if Bookmark Exist
With .Bookmarks.Item("Table_Info").range.Tables(1) ' Work on Table Bookmarked as Table_Info
ColN = 1
For RowN = 1 To 10
.Rows(RowN).Cells(ColN).range.Text = "Col= " & ColN & " Row= " & RowN '"Column1RowN"
.Rows(RowN).Cells(ColN + 1).range.Text = "Col= " & ColN & " Row= " & RowN '"Column2RowN"
.Rows(RowN).Cells(ColN + 2).range.Text = "Col= " & ColN & " Row= " & RowN '"Column3RowN"
Next RowN
End With
.Bookmarks.Item("Table_Info").Delete
End If
End With
WD.SaveAs TempFolder & "1.docx"
WD.Close False
Set WD = Nothing
WA.Quit False
Set WA = Nothing
End Sub
Function IsBM(ByVal WDs As Object, ByVal BookMarkName As String) As Boolean
On Error Resume Next
IsBM = WDs.Bookmarks.Exists(BookMarkName)
End Function