[XL-2007] copie et insertion

[amouna98]

Je programme occasionnellement en vba
Mon problème aujourd'hui et de faire des copies automatiques, je m'explique :
j'ai plusieurs feuilles qui on la même structure ( D1,D2,D3,D4)
Dans chaque feuille je serai intéressé par la colonne B à partir de la ligne 14
Il faut que je copie toutes les cellules non vides à partir de la ligne 14 de la colonne B dans une autre feuille (colonne 1, à partir de la ligne 4)
J’arrive à faire ca pour une feuille avec le code suivant

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 
Sub Macro1()
 
Dim Lig     As Long
  Dim Col     As String
  Dim NbrLig  As Long
  Dim NumLig  As Long
 
  Sheets("Feuil2").Activate ' feuille de destination
 
  Col = "B"                 ' colonne de la donnée non vide à tester
  NumLig = 2
  With Sheets("D1")     ' feuille source
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 14 To NbrLig
    If .Cells(Lig, Col).Value <> "" Then
      .Cells(Lig, Col).Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      ActiveSheet.Paste
    End If
  Next
  End With
 
End Sub

Mon problème c'est que je veux développer chaque ligne donc pour chaque cellule copiée je veux insérer des lignes de critères (plusieurs lignes dans la colonne à coté)
Ces critères sont les même pour chaque donc je veux copier une cellule puis mètre les lignes "critère" puis copier la cellule d’après ou copier tout puis insérer les lignes de critères
Voir image