Filtre selon critères, Export, ajoût lignes et déplacement de cellule dynam

Bien le bonjour à tous,

J'ai une macro qui effectue les actions suivantes:

• (Avant run macro) Sélectionner plusieurs critères dans des listes déroulantes pour choisir les filtres.
• Lancer la macro:
• Filtrer le tableau général en feuil1
• Copier/coller les lignes adéquates dans feuil2
• Réinitialiser les filtres de feuil1 pour montrer ce qui a été masqué
• Ajouter une ligne vide en-dessous de chaque résultat de feuil2.

(donc jusque là c'est tout bon)

Ce que je ne parviens pas à faire (dans l'ordre):

► Fusionner les cellules ("A:O" dynamique) de ces lignes vides (test Si ligne = "" alors .Merge en gros; j'avais réussi à le faire par accident avec les lignes au-dessus des entêtes (ligne 15) du tableau mais je n'arrive pas à le refaire...)

► Mettre la cellule P de chaque résultat dans cette fameuse ligne vide du dessous (il s'agit d'une description de transaction, donc une longue phrase).

► Formater (cadre gras) la ligne résultat avec la ligne description pour qu'on comprenne bien qu'elles sont ensemble.

► Faire le poirier (petite boutade du matin)...

A noter que:

♥ BDD feuille 1 est un tableau dynamique

♥ Export feuille 2 n'est pas un tableau

♥ Dans les deux cas, entêtes = ligne 15; donc plage = A16:Px

♥ Je ne peux pas partager le fichier c'est il est tip top secret

♥ Je sais que la réponse pour .Merge est sans doute dans la déclaration des variables, mais j'y arrive pas...

Pour illustrer: Actuel vs souhaité (col. A = n°; col. P = object)

Ici les résultats de critères "dptA" et "X".

Ce qui fonctionne jusqu'à maintenant:

Option Explicit

Sub CustomExport()
  Dim shtGen As Worksheet, shtTotal As Worksheet
  Dim cDir, cType
  Dim lr As Long
  Dim lrt As Long
  Dim r As Range

  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).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

Dim rngT As Range
Dim rowT As Long
Set rngT = shtTotal.Range("A16:P" & lrt)

For rowT = rngT.Rows.Count To 2 Step -1
    rngT.Rows(rowT).EntireRow.Insert
Next rowT

End Sub

Ce qui ne fonctionne pas + tentatives:

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

Set rngT = shtTotal.Range("A16:P" & lrt)
arrT = Array(shtTotal.Range("A16:A" & lrt).Rows.Count)

' Add blank row N+1 & Format cell
For rowT = rngT.Rows.Count To 2 Step -1
    rngT.Rows(rowT).EntireRow.Insert

' Here with ".Range("A:O" & r) I managed to merge rows above headers...
'        For Each r In arrT
'            If r = "" Then
'                rngT.Rows(rowT).Range("A16:O", r) _
'                    .Merge _
'                    .HorizontalAlignment = xlCenter _
'                    .VerticalAlignment = xlCenter
'            Else
'            End If
'        Next r
Next rowT

' Convert P

'=========

' Failures:
'    rngT.Rows(rowT).Row.Range("A:A,O:O").Select _
'        .HorizontalAlignment = xlCenter
'        .VerticalAlignment = xlCenter

' Merge blank rows
'For Each r.Row In rngT
'    If r = "" Then
'        r.Cells("A:O") _
'            .Merge
'            .HorizontalAlignment = xlCenter
'            .VerticalAlignment = xlCenter
'    End If
'Next r

'        With rowT.Range("A:O")
'            .Merge
'            .HorizontalAlignment = xlCenter
'            .VerticalAlignment = xlCenter
'        End With

'If IsEmpty(rngT.Rows(r)) = True Then

End Sub

Que votre sagesse infinie me guide

Merci,

Bisou,

Lucas