Microsoft 365 Amélioration Macro pour importer des données selon critères

[xls_62]

Bonjour,
J'ai un code VBA pour importer des données de la feuille1 ( base des données ) vers la feuille 2 ( feuille on colle les données souhaitées ) selon critère renseigné dans la feuille2 ( cellule : ligne 2 / colonne 5) => Avec le code ci dessous tout fonctionne parfaitement

AMELIORATION SOUHAITEE : Comment dupliquer cette macro sur plusieurs feuilles par exemple Feuil3, Feuil4 etc ?

merci de votre aide.
---------------
Sub importBis()
Dim fin&, aa, bb 'A,B,C,E,G,H et L
With Feuil1
aa = .Range("A2:M" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
y = 1
ReDim bb(7, y)
For i = 1 To UBound(aa)
If aa(i, 11) = Feuil2.Cells(2, 5) Or aa(i, 11) = Feuil2.Cells(2, 5).Text Then
x = 1
ReDim Preserve bb(7, y)
For Each a In Array(1, 2, 3, 5, 7, 8, 12)
bb(x, y) = aa(i, a): x = x + 1
Next a
y = y + 1
End If
Next i
With Feuil2
fin = .Range("A" & Rows.Count).End(xlUp).Row
If fin <= 6 Then GoTo 1
.Range("A7:M" & fin).Clear
1 .Range("A7").Resize(UBound(bb, 2), UBound(bb)) = Application.Transpose(bb)
.Columns("A:G").AutoFit
End With
MsgBox "Copie Effectuée "
End Sub
--------

 

[pierrejean]

Bonjour
A tester

Sub importBis()
Dim fin&, aa, bb 'A,B,C,E,G,H et L
feuilles = Split("Feuil1,Feuil3,Feuil4,Feuil5", ",")
For n = LBound(feuilles) To UBound(feuilles)
With Sheets(feuilles(n))
aa = .Range("A2:M" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
y = 1
ReDim bb(7, y)
For i = 1 To UBound(aa)
If aa(i, 11) = Feuil2.Cells(2, 5) Or aa(i, 11) = Feuil2.Cells(2, 5).Text Then
x = 1
ReDim Preserve bb(7, y)
For Each a In Array(1, 2, 3, 5, 7, 8, 12)
bb(x, y) = aa(i, a): x = x + 1
Next a
y = y + 1
End If
Next i
With Feuil2
fin = .Range("A" & Rows.Count).End(xlUp).Row
If fin <= 6 Then GoTo 1
.Range("A7:M" & fin).Clear
1 .Range("A7").Resize(UBound(bb, 2), UBound(bb)) = Application.Transpose(bb)
.Columns("A:G").AutoFit
End With
Next n
MsgBox "Copie Effectuée "
End Sub

 

[xls_62]

Bonjour pierre jean,
Merci de ce retour .
par contre le critère de sélection est renseignée dans la même feuille..
donc le code : If aa(i, 11) = Feuil2.Cells(2, 5) Or aa(i, 11) = Feuil2.Cells(2, 5).Text Then à changer non ?

 

[pierrejean]

Re
Ce n'est pas ce qui parait dans le code initial (With Feuil1)
Si même feuille supprimer Feuil2

 

[xls_62]

Re
Ce n'est pas ce qui parait dans le code initial (With Feuil1)
Si même feuille supprimer Feuil2

si , EN VERT les critères de sélection

Sub importBis()
Dim fin&, aa, bb 'A,B,C,E,G,H et L
With Feuil1
aa = .Range("A2:M" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
y = 1
ReDim bb(7, y)
For i = 1 To UBound(aa)
If aa(i, 11) = Feuil2.Cells(2, 5) Or aa(i, 11) = Feuil2.Cells(2, 5).Text Then
x = 1
ReDim Preserve bb(7, y)
For Each a In Array(1, 2, 3, 5, 7, 8, 12)
bb(x, y) = aa(i, a): x = x + 1
Next a
y = y + 1
End If
Next i
With Feuil2
fin = .Range("A" & Rows.Count).End(xlUp).Row
If fin <= 6 Then GoTo 1
.Range("A7:M" & fin).Clear
1 .Range("A7").Resize(UBound(bb, 2), UBound(bb)) = Application.Transpose(bb)
.Columns("A:G").AutoFit
End With
MsgBox "Copie Effectuée "
End Sub

 

[xls_62]

Re
Ce n'est pas ce qui parait dans le code initial (With Feuil1)
Si même feuille supprimer Feuil2

Pierre jean,
en Pj qui correspond à mon besoin

 

[pierrejean]

Re
Désolé je ne comprends pas !!!
NB : ta macro appliquée au fichier ne parait pas donner de résultat

 

[xls_62]

peut on partir sur une nouvelle macro avec le fichier envoyé ?