选择合并单元格的两行标记为标题

编程问答 2022-10-03

问题描述

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

layout of merged cells

因此，我收到运行时错误 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:="*",SearchOrder:=xlByColumns,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:=" _ ",MatchWholeWord:=True,ReplaceWith:=" / "
            .Application.Selection.Collapse (wdCollapseEnd)
            .Application.Selection.Find.Execute FindText:="<<" & Ws.Name & "_Content>>",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

解决方法

看这里：

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 范围内获取单元格计数...

ms-wordrowsselectionvba