VBA Paste below collapsed Group - excel

Question

I have a macro that copies rows from a Sheet named "Template" and pastes them onto the Active Sheet in the next blank row.
However this macro only works when the grouped cells on the Active Sheet are expanded.
If the grouped cells are collapsed, then the macro replaces a previous collapsed group.
I have done some reading and discovered that using a different method to calculate the last row i.e. the MergeArea property would work with collapsed groups but just sure how to apply it.
How could I achieve this with the current code?
This is my code:
Sub Paste_New_Product_from_Template()
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim LRow As Long, i As Long
Dim StartNumber As Long
Dim varString As String
'~~> This is your input sheet
Set copySheet = ThisWorkbook.Worksheets("Template")
'~~> Variable
varString = copySheet.Cells(2, 2).Value2
'~~> Change this to the relevant sheet
Set pasteSheet = ThisWorkbook.ActiveSheet
'~~> Initialize the start number
StartNumber = 1
With pasteSheet
'~~> Find the last cell to write to
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
LRow = 2
Else
LRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Find the previous number
For i = LRow To 1 Step -1
If .Cells(i, 2).Value2 = varString Then
StartNumber = .Cells(i, 6).Value2 + 1
Exit For
End If
Next i
End If
copySheet.Range("2:" & copySheet.Cells(Rows.Count, 1).End(xlUp).Row).Copy
.Rows(LRow).PasteSpecial Paste:=xlPasteAll
'~~> Set the start number
.Cells(LRow, 6).Value = StartNumber
'~~> Format the number
.Cells(LRow, 6).Value = "'" & Format(StartNumber, "000")
End With
End Sub
Here is the code that uses the MergeArea procedure:
Private Function RowIsEmpty(WSh As Worksheet, Row As Long, StartColumnNumber As Integer, EndColumnNuber As Integer) As Boolean
Dim j As Integer
RowIsEmpty = True
For j = StartColumnNumber To EndColumnNuber
If (WSh.Cells(WSh.Cells(Row, j).MergeArea.Row, WSh.Cells(Row, j).MergeArea.Column) <> "") Then
RowIsEmpty = False
Exit For 'One of columns isn't empty
End If
Next j
End Function
Private Function CalcLastRowNumber(WSh As Worksheet, StartColumnNumber As Integer, EndColumnNuber As Integer) As Long
Dim i As Long
Dim j As Integer
Dim Result As Long
Dim Found As Boolean
Result = 1
For i = 1 To Rows.Count
If RowIsEmpty(WSh, i, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 1, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 2, StartColumnNumber, EndColumnNuber) Then
'Stop searching
Exit For 'All Columns are empty for current row and for next 2 rows
End If
Result = i
Next i
CalcLastRowNumber = Result
End Function
Sub New_Reviss_Order()