从 Excel 在 Word 文档中插入可调表

Question

我将有两种情况：

否则，第一个单元格将包含更多由“;”分隔的值如下：

这些情况应该会导致不同的表格插入到我用 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 所建议的，但它不起作用。

Answer 1

例如，假设基本表已经存在，并且您有代码用预处理数据填充行：

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, ";")(j)), " ")(1), ")", ""), "(", "")
                                Next
                            End If
                            If InStr(StrTxt, " ") > 0 Then
                                .Cell(r, c).Range.Text = Split(Trim(Split(StrTxt, ";")(0)), " ")(0)
                                .Cell(r, c + 1).Range.Text = Replace(Replace(Split(Trim(Split(StrTxt, ";")(0)), " ")(1), ")", ""), "(", "")
                            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