问题描述
我会遇到两种情况：
否则第一个单元格将包含更多由“;”分隔的值如下：
这些情况应该会导致不同的表格，这些表格应该插入到我使用 Excel 中的 VBA 打开的预先存在的 Word 文档中。
结果表如下所示：
我只是在 Word 文档中插入了一个“固定”表格并替换了内部值，这已经不够了。
这是我用来打开 Word 文档并替换某些单词并将新制作的 Word 文档另存为 docx 和 pdf 格式的新文件的代码：
Sub Sample()
Const wdFindContinue As Long = 1
Const wdReplaceAll As Long = 2
Const StrNoChr As String = """*./\:?|"
Dim oWordApp As Object,oWordDoc As Object,rngStory As Object
Dim sFolder As String,strFilePattern As String
Dim strFileName As String,sFileName As String
Dim cant As Integer
Dim tex As String
Dim max As Integer
Dim total As Integer
Dim final As Integer
sFolder = "C:\Users\name\folder\"
On Error Resume Next
Set oWordApp = Getobject(,"Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWordDoc = oWordApp.Documents.Open(sFileName)
For Each rngStory In oWordDoc.StoryRanges
With rngStory.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
StrName = Sheets(1).Cells(i,2)
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName,Mid(StrNoChr,j,1),"_")
Next j
StrName = Trim(StrName)
With oWordDoc
.SaveAs Filename:=sFolder & StrName & ".docx",FileFormat:=wdFormatXMLDocument,AddToRecentFiles:=False
'.SaveAs Filename:=sFolder & StrName & ".pdf",FileFormat:=wdFormatPDF,AddToRecentFiles:=False
.ExportAsFixedFormat sFolder & StrName & ".pdf",17
.Close SaveChanges:=False
End With
Next i
oWordApp.Quit
Set oWordDoc = nothing
Set oWordApp = nothing
MsgBox "Succes"
End Sub
代码与具体问题无关，但可能会提供一些灵感或其他想法。
编辑： 我试过这个：
ActiveDocument.Tables.Add Range:=Selection.Range,NumRows:=2,NumColumns:= 4
按照 MacroPod 的建议，但它不起作用。
解决方法
例如，假设基本表已经存在，并且您有代码来使用预处理数据填充行：
Sub Demo()
Dim oWdApp As Object,oWdDoc As Object,oWdRng As Object,oWdTbl As Object
Dim sFolder As String,sFileName As String,StrTxt As String
Dim last_row As Long,r As Long,c As Long,i As Long,j As Long
Const wdFindContinue As Long = 1: Const wdReplaceAll As Long = 2
Const wdFormatXMLDocument As Long = 12: Const wdFormatPDF As Long = 17
Const StrNoChr As String = """*./\:?|"
sFolder = "C:\Users\name\folder\"
Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("Data")
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
On Error Resume Next
Set oWdApp = GetObject(,"Word.Application")
If Err.Number <> 0 Then
Set oWdApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWdApp.Visible = False
For i = 2 To last_row
sFileName = sFolder & "wordfile.docx"
Set oWdDoc = oWdApp.Documents.Add(sFileName)
With oWdDoc
For Each oWdRng In .StoryRanges
With oWdRng.Find
If sh.Range("C" & i).Value <> "" Then
.Text = "_Name1"
.Replacement.Text = sh.Range("C" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
If sh.Range("D" & i).Value <> "" Then
.Text = "_Name2"
.Replacement.Text = sh.Range("D" & i).Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End If
End With
Next
For Each oWdTbl In .Tables
With oWdTbl
For r = .Rows.Count To 2 Step -1
For c = 1 To .Rows(r).Cells.Count Step 2
StrTxt = Split(.Cell(r,c).Range.Text,vbCr)(0)
If InStr(StrTxt,";") > 0 Then
For j = 1 To UBound(Split(StrTxt,";"))
If r = .Rows.Count Then
.Rows.Add
Else
.Rows.Add .Rows(r + 1)
End If
.Cell(r + j,c).Range.Text = Split(Trim(Split(StrTxt,";")(j))," ")(0)
.Cell(r + j,c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt," ")(1),")",""),"(","")
Next
End If
If InStr(StrTxt," ") > 0 Then
.Cell(r,";")(0))," ")(0)
.Cell(r,"")
End If
Next
Next
End With
Next
StrName = Sheets(1).Cells(i,2).Text
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName,Mid(StrNoChr,j,1),"_")
Next j
StrName = Trim(StrName)
.SaveAs Filename:=sFolder & StrName & ".docx",FileFormat:=wdFormatXMLDocument,AddToRecentFiles:=False
.SaveAs Filename:=sFolder & StrName & ".pdf",FileFormat:=wdFormatPDF,AddToRecentFiles:=False
.Close SaveChanges:=False
End With
Next i
oWdApp.Quit
Set oWordDoc = Nothing: Set oWdApp = Nothing: Set oWdRng = Nothing: Set oWdTbl = Nothing: Set sh = Nothing
MsgBox "Succes"
End Sub