copie et insertion

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