Offset on merged cells dynamically after dynamic row insertion

YourBroLucas

New Member
Joined
Jul 11, 2022
Messages
29
Office Version
  1. 2016
Platform
  1. Windows
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:

VBA Code:
' 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:

VBA Code:
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
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top