YourBroLucas
New Member
- Joined
- Jul 11, 2022
- Messages
- 29
- Office Version
- 2016
- Platform
- 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:
Here is the full macro:
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 SubHere 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
