Offset on merged cells dynamically after dynamic row insertion

[YourBroLucas]

Howdy,

So I have this macro that filters and then copy/pastes data from column A to P.

On the sheet where that filtered data is pasted, I want to move each result from column P into a blank row below said result.

I successfully added a blank row below each result dynamically, but I struggle to move Row X column P there.

I've tried to deal with the issues caused by merging cells Ax to Px but failed miserably.

Problematic section and full code below

Online solutions I've sought involve static databases

♥ Any idea would be greatly appreciated! ♥

With love,

Here's the problematic section:

' Part two: Convert Row N column P & put in Row N + 1
Dim rngT As Range
Dim rowT As Long
Dim i As Variant

Set rngT = shtTotal.Range("A16:P" & lrt)

' Add blank row X+1
For rowT = rngT.Rows.Count To 2 Step -1
    rngT.Rows(rowT).EntireRow.Insert
    rngT.Rows(rowT).Columns("A:P").Merge
Next rowT

' Merge blank row below last row
shtTotal.Range("A" & Rows.Count).End(xlUp).Offset(1) _
    .Columns("A:P").Merge
'
' === Supposed to put cell P into next (blank) row ===

' Attempt 1: Does nothing
'For rowT = rngT.Rows.Count To 2
'    rngT.Rows(rowT).Column("P").Copy _
'    .Offset(1).PasteSpecial Paste:=xlPasteValues
'Next rowT

' Attempt 2: "Error 1004: The size of merged cells must be identical"
'For i = 16 To lrt
'    If IsEmpty(i) = False Then
'        shtTotal.Cells(i, 16).Copy
'        Range("A16:P" & i).Offset(1).PasteSpecial Paste:=xlPasteValues
'    Else
'    End If
'Next i

' Attempt 3: Messes everything + err 1004
'Put merge code after Attempt 2's Offset

End Sub

Here is the full macro:

Option Explicit

Sub CustomExport()

' Part One: Filter and export
  Dim shtGen As Worksheet, shtTotal As Worksheet
  Dim cDir, cType
  Dim lr As Long
  Dim lrt As Long

  Set shtGen = ActiveWorkbook.Worksheets("Tab_Général")
  Set shtTotal = ActiveWorkbook.Worksheets("RECAP_TOTAL")

' shtGen show all
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=3
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=14
  shtGen.ListObjects("Tableau12").Sort.SortFields.Clear
  shtGen.ListObjects("Tableau12").Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
  xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

' Clear former export
  If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  lr = shtGen.Range("C" & Rows.Count).End(3).Row
  shtTotal.Range("A16:P" & Rows.Count).UnMerge
  shtTotal.Range("A16:P" & Rows.Count).ClearContents
  shtTotal.Range("A16:P" & Rows.Count).ClearFormats

  cDir = shtTotal.Range("B6").Value
  cType = shtTotal.Range("B7").Value

  With shtGen.Range("A15:P" & lr)
    If cDir <> "" Then .AutoFilter 3, cDir Else .AutoFilter 3, "*"
    If cType <> "" Then .AutoFilter 14, cType Else .AutoFilter 14, "*"
  End With

  If shtGen.Range("C" & Rows.Count).End(3).Row > 16 Then
    shtGen.AutoFilter.Range.Offset(1).Copy shtTotal.Range("A16")
    If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  Else
  End If

' shtGen show all + chronological order
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=3
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=14
  shtGen.ListObjects("Tableau12").Sort.SortFields.Clear
  shtGen.ListObjects("Tableau12").Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
  xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

  With shtGen.ListObjects("Tableau12").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With

' Msg if no result
lrt = shtTotal.Range("A" & Rows.Count - 1).End(xlUp).Row
    With shtTotal.Range("A16:P" & lrt)
        If Application.WorksheetFunction.Sum(shtTotal.Range("A16:P" & lrt)) = 0 Then
            MsgBox "Aucun résultat trouvé"
        Else
        End If
    End With

' Part two: Convert Row N column P & put in Row N + 1
Dim rngT As Range
Dim rowT As Long
Dim i As Variant

Set rngT = shtTotal.Range("A16:P" & lrt)

' Add blank row X+1
For rowT = rngT.Rows.Count To 2 Step -1
    rngT.Rows(rowT).EntireRow.Insert
    rngT.Rows(rowT).Columns("A:P").Merge
Next rowT

' Merge blank row below last row
shtTotal.Range("A" & Rows.Count).End(xlUp).Offset(1) _
    .Columns("A:P").Merge
'
' === Supposed to put cell P into next (blank) row ===

' Attempt 1: Does nothing
'For rowT = rngT.Rows.Count To 2
'    rngT.Rows(rowT).Column("P").Copy _
'    .Offset(1).PasteSpecial Paste:=xlPasteValues
'Next rowT

' Attempt 2: "Error 1004: The size of merged cells must be identical"
'For i = 16 To lrt
'    If IsEmpty(i) = False Then
'        shtTotal.Cells(i, 16).Copy
'        Range("A16:P" & i).Offset(1).PasteSpecial Paste:=xlPasteValues
'    Else
'    End If
'Next i

' Attempt 3: Messes everything + err 1004
'Put merge code after Attempt 2's Offset

End Sub