选择包含合并单元格的两行以标记为标题答案

【问题标题】：Select two rows with merged Cells to mark as Header选择包含合并单元格的两行以标记为标题
【发布时间】：2021-09-28 22:49:29
【问题描述】：

我有一个宏，它从我的工作簿的不同工作表中获取数据并将其写入一个 word 文件。当我尝试将某些单元格标记为表格的标题时，它会发生唯一的问题。我想将最上面的两行作为表格的标题，但是这两行包含一些合并的单元格，合并单元格的布局可以在附图中看到。因此，我收到运行时错误 5991 抱怨合并单元格。

如果我在 word 中手动选择问题中的行并右键单击 -> 属性 -> 标题检查它是否按预期工作，所以我怀疑问题在于行的选择。这似乎是一个非常简单的解决方法，但我无法找出正确的关键字来找到正确的答案。

Sub mytry()
    Dim tblRange As Excel.Range
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim WordTable As Word.Table
    Dim str As String
    Dim Ws As Worksheet
    Dim lRow As Integer, lCol As Integer
    Dim i As Long, j As Long
    
    Set WordApp = GetObject(class:="Word.Application")
    If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    WordApp.Visible = True
    WordApp.Activate

    Set WordDoc = WordApp.Documents.Add(Template:="filename", NewTemplate:=False, DocumentType:=0)
    
    For Each Ws In ActiveWorkbook.Worksheets
        ' Produces a String of Placeholders for the Word template as I don't know in advance how many worksheets there are
        str = str & "<<" & Ws.Name & "_Heading>>" & vbLf & "<<" & Ws.Name & "_Content>>"
    Next
    
    With WordDoc
        .Application.Selection.Find.Text = "<<Data>>" ' Placeholder in the Word Template where all of my Data goes.
        .Application.Selection.Find.Execute
        .Application.Selection = str
    End With
    
    For Each Ws In ActiveWorkbook.Worksheets
        ' finds last used Cell in the Worksheet
        lRow = Ws.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        lCol = Ws.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        str = SpaltNoZuBuchst(lCol) & CStr(lRow)
        Debug.Print str

        Set tblRange = Ws.Range("A1:" & str)
        tblRange.Copy

        With WordDoc
            .Application.Selection.Find.Execute FindText:="<<" & Ws.Name & "_Heading>>", MatchCase:=True, MatchWholeWord:=True
            .Application.Selection = Ws.Name
            .Application.Selection.Style = WordDoc.Styles("Heading 1")
            .Application.Selection.Find.Execute FindText:=" _ ", MatchCase:=True, MatchWholeWord:=True, ReplaceWith:=" / "
            .Application.Selection.Collapse (wdCollapseEnd)
            .Application.Selection.Find.Execute FindText:="<<" & Ws.Name & "_Content>>", MatchCase:=True, MatchWholeWord:=True
            .Application.Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
        End With
        i = i + 1 ' indexes the newly inserted Table
        Set WordTable = WordDoc.Tables(i)
        WordTable.Rows(1).HeadingFormat = True
        WordTable.Rows(2).HeadingFormat = True ' first and second row contain Heading Information
        WordTable.AutoFitBehavior (wdAutoFitWindow)
        WordDoc.Application.Selection.Collapse (wdCollapseEnd)
        WordDoc.Application.Selection.InsertBreak
    Next

    WordDoc.TablesOfContents(1).Update
    WordDoc.Fields.Update
End Sub

Function SpaltNoZuBuchst(Num As Integer) As String
    Dim eins As Integer, zwei As Integer
    Dim str As String
    
    eins = Int((Num - 1) / 26)
    If eins - 1 > 0 Then zwei = Int((eins - 1) / 26)
    
    If zwei > 0 Then str = Chr(zwei + 64)
    If eins - zwei * 26 > 0 Then str = str + Chr(eins - zwei * 26 + 64)
    str = str + Chr(Num - eins * 26 + 64)
    
    SpaltNoZuBuchst = str
End Function

【问题讨论】：

标签： vba ms-word rows selection

【解决方案1】：

看这里：

Failing to set table heading if there are merged rows

改编自链接的帖子：

WordTable.Cell(1, 1).Range.Select
Selection.MoveEnd wdCell, 10   '<< how many cells in top 2 rows 
Selection.Rows.HeadingFormat = True

您可以从 Excel 范围中获取单元格计数...

【讨论】：