Select two rows with merged Cells to mark as Header - vba

Question

I have a macro that takes data from different worksheets of my workbook and writes it into a word file. It does what it should the only problem occurs when I try to mark some cells as the header of the table. I want to have the two top rows as a header of my table but the two rows contain some merged cells, the layout of the merged cells can be seen in the attached image.
and because of that I receive the runtime error 5991 complaining about merged cells.
If I select the rows in questions manually in word and do the right click -> properties -> header check it works as intended so I suspect that the problem lies in the selection of the rows. It seems like a very simple fix but I am just unable to figure out the correct keywords for finding the right answer.
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

Answer 1

See here:
Failing to set table heading if there are merged rows
Adapted from the linked post:
WordTable.Cell(1, 1).Range.Select
Selection.MoveEnd wdCell, 10 '<< how many cells in top 2 rows
Selection.Rows.HeadingFormat = True
You can get the cell count from your Excel range...