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

xls_62

XLDnaute Nouveau
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

XLDnaute Barbatruc
Bonjour
A tester
VB:
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

XLDnaute Nouveau
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 ?
 

xls_62

XLDnaute Nouveau
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
 

Discussions similaires

  • Résolu(e)
Microsoft 365 Fond de couleur
Réponses
2
Affichages
299

Statistiques des forums

Discussions
291 805
Messages
1 918 117
Membres
179 932
dernier inscrit
Starsat1200
Haut Bas