Extraire des lignes

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
M

matthieu2701

XLDnaute Occasionnel
Bonjour à tous,

Je viens vers vous car je souhaite extraire, sur une nouvelle feuille, les lignes qui contiennent une donnée d'une colonne.

Dans mon fichier, j'aimerais extraire les lignes dont la colonne P contient "Fabricant1" dans une feuille et "Fabricant2" + "Fabricant3" dans une autre feuille.

Je vous joint le fichier.

Merci par avance
 

Pièces jointes

Trier par date Trier par votes
Bonjour
Puis-je avoir le code de la macro car mon entreprise bloque la macro à l'ouverture du fichier stp ?
Cliquez pour agrandir...
refléchiquestion gif.gif
 
Vote positif 0 Vote négatif
Re,

Par VBA avec le texte d'une macro dans un module :
VB: 
Sub ventiler()
Dim ts As ListObject, i&, j&, i1&, i2&, n&, t, t1, t2
   Application.ScreenUpdating = False
   Set ts = Worksheets("BDD").Range("a1").ListObject: n = ts.ListColumns.Count
   On Error Resume Next
   i = 0: i = Worksheets("Fabricant1").Range("a1").CurrentRegion.Clear
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant1"
   Worksheets("Fabricant1").Columns(1).Resize(, n).Clear
   i = 0: i = Worksheets("Fabricant-autres").Index
   On Error GoTo 0
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant-autres"
   Worksheets("Fabricant-autres").Columns(1).Resize(, n).Clear
   t = ts.Range: t1 = ts.Range: t2 = ts.Range: i1 = 1: i2 = 1
   For i = 2 To UBound(t)
      If t(i, 16) = "Fabricant1" Then
         i1 = i1 + 1
         For j = 1 To n: t1(i1, j) = t(i, j): Next
      Else
         i2 = i2 + 1
         For j = 1 To n: t2(i2, j) = t(i, j): Next
      End If
   Next i
    Worksheets("Fabricant1").Range("a1").Resize(i1, n) = t1
    Worksheets("Fabricant-autres").Range("a1").Resize(i2, n) = t2
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Re,

Une version qui présente les résultats sous forme de tableaux structurés de noms "tsFab1" et "tsFabN".
VB: 
Sub ventiler()
Dim ts As ListObject, i&, j&, i1&, i2&, n&, t, t1, t2
   Application.ScreenUpdating = False
   Set ts = Worksheets("BDD").Range("a1").ListObject: n = ts.ListColumns.Count
   On Error Resume Next
   i = 0: i = Worksheets("Fabricant1").Range("a1").CurrentRegion.Clear
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant1"
   Worksheets("Fabricant1").Columns(1).Resize(, n).Clear
   i = 0: i = Worksheets("Fabricant-autres").Index
   On Error GoTo 0
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant-autres"
   Worksheets("Fabricant-autres").Columns(1).Resize(, n).Clear
   t = ts.Range: t1 = ts.Range: t2 = ts.Range: i1 = 1: i2 = 1
   For i = 2 To UBound(t)
      If t(i, 16) = "Fabricant1" Then
         i1 = i1 + 1
         For j = 1 To n: t1(i1, j) = t(i, j): Next
      Else
         i2 = i2 + 1
         For j = 1 To n: t2(i2, j) = t(i, j): Next
      End If
   Next i
   With Worksheets("Fabricant1")
      .Range("a1").Resize(i1, n) = t1
      .ListObjects.Add(xlSrcRange, .Range("a1").Resize(i1, n), , xlYes).Name = "tsFab1"
      .ListObjects("tsFab1").TableStyle = "TableStyleMedium7"
   End With
   With Worksheets("Fabricant-autres")
      .Range("a1").Resize(i2, n) = t2
      .ListObjects.Add(xlSrcRange, .Range("a1").Resize(i2, n), , xlYes).Name = "tsFabN"
      .ListObjects("tsFabN").TableStyle = "TableStyleMedium5"
   End With
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
mapomme à dit:
Re,

Par VBA avec le texte d'une macro dans un module :
VB: 
Sub ventiler()
Dim ts As ListObject, i&, j&, i1&, i2&, n&, t, t1, t2
   Application.ScreenUpdating = False
   Set ts = Worksheets("BDD").Range("a1").ListObject: n = ts.ListColumns.Count
   On Error Resume Next
   i = 0: i = Worksheets("Fabricant1").Range("a1").CurrentRegion.Clear
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant1"
   Worksheets("Fabricant1").Columns(1).Resize(, n).Clear
   i = 0: i = Worksheets("Fabricant-autres").Index
   On Error GoTo 0
   If i = 0 Then Worksheets.Add: ActiveSheet.Name = "Fabricant-autres"
   Worksheets("Fabricant-autres").Columns(1).Resize(, n).Clear
   t = ts.Range: t1 = ts.Range: t2 = ts.Range: i1 = 1: i2 = 1
   For i = 2 To UBound(t)
      If t(i, 16) = "Fabricant1" Then
         i1 = i1 + 1
         For j = 1 To n: t1(i1, j) = t(i, j): Next
      Else
         i2 = i2 + 1
         For j = 1 To n: t2(i2, j) = t(i, j): Next
      End If
   Next i
    Worksheets("Fabricant1").Range("a1").Resize(i1, n) = t1
    Worksheets("Fabricant-autres").Range("a1").Resize(i2, n) = t2
End Sub
Cliquez pour agrandir...
Merci
 
Vote positif 0 Vote négatif
matthieu2701 à dit:
Les macros je peux. Je comprends pourquoi c’est bloqué alors. C’est par rapport à power query
Cliquez pour agrandir...
Bonsoir,
Je pense que, soit tu te trompes (et tu ne sais pas ce qu'il se passe), soit ta boîte marche sur la tête...
Autoriser les macros, et suspendre Power Query (si d'ailleurs c'est possible????)
Donc, hypothèse première privilégiée
Et par ailleurs, tu avais également eu une proposition Power Query sur l'autre forum (sans réponse envers le bénévole d'ailleurs...)
Bonne soirée
 
Vote positif 0 Vote négatif
Cousinhub à dit:
Bonsoir,
Je pense que, soit tu te trompes (et tu ne sais pas ce qu'il se passe), soit ta boîte marche sur la tête...
Autoriser les macros, et suspendre Power Query (si d'ailleurs c'est possible????)
Donc, hypothèse première privilégiée
Et par ailleurs, tu avais également eu une proposition Power Query sur l'autre forum (sans réponse envers le bénévole d'ailleurs...)
Bonne soirée
Cliquez pour agrandir...
Salut, quand j’ouvre le fichier, cela me note un message comme quoi la macro a été bloquée pour une question de sécurité.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

R
  • Question Question
XL pour MAC Extraire des noms à partir d'une liste
Réponses
8
Affichages
356
rtlv17
R
S
  • Résolu(e)
Microsoft 365 PowerQuery : Table.addColumns en erreur
Réponses
2
Affichages
64
Sissou71
S
A
  • Question Question
Déplacer données en vba
Réponses
3
Affichages
431
akm
A
S
  • Question Question
Microsoft 365 Extraire dans une nouvelle feuille les cellules non vide d'une colonne
2
Réponses
15
Affichages
334
Gégé-45550
Gégé-45550
A
  • Question Question
Autres Extraire des nombres par département
Réponses
9
Affichages
173
wDog66
wDog66
S
  • Résolu(e)
Microsoft 365 Actualiser formules matricielles
Réponses
3
Affichages
103
Standpi
S
F
  • Question Question
macro événementielle
2
Réponses
18
Affichages
370
FDO94
F
ExcelDow
  • Résolu(e)
Microsoft 365 Modifier un code copie donnée chaque feuil séparément
Réponses
11
Affichages
252
ExcelDow
ExcelDow
Z
  • Question Question
Microsoft 365 Définir des plages de dates
Réponses
9
Affichages
226
Zazagally
Z
Dudu2
  • Résolu(e)
XL 2016 VBA - Trouver les feuilles d'un classeur fermé
12 13 14
Réponses
196
Affichages
3 K
patricktoulon
patricktoulon
G
  • Question Question
Microsoft 365 Filtrer lignes par quart d'heures
2 3
Réponses
33
Affichages
869
Cousinhub
Cousinhub
M
  • Question Question
XL 2016 pb création de tableau par macro
Réponses
10
Affichages
202
ChTi160
ChTi160
A
  • Question Question
XL 2021 modifier lignes
4 5 6
Réponses
75
Affichages
1 K
AIGOIN
A
S
  • Résolu(e)
Autres Problème avec sélection d'une cellule puis glisser
Réponses
2
Affichages
148
SPARKLETOF
S
D
  • Résolu(e)
Microsoft 365 Assistance pour optimisation d'un code VBA qui ne fonctionne pas comme souhaité
2
Réponses
21
Affichages
592
desto
D
P
  • Résolu(e)
Microsoft 365 Suppression lignes par rapport à une date
2 3 4
Réponses
50
Affichages
735
pierrof
P
Y
  • Question Question
XL 2019 Masquer automatiquement des lignes selon la valeur d'une cellule ?
Réponses
2
Affichages
232
Yogean
Y
Caninge
  • Résolu(e)
XL 2019 Extraction de données dans une autre plage !
Réponses
6
Affichages
482
Caninge
Caninge
D
  • Question Question
Microsoft 365 Aide pour Extraire des données selon critères
Réponses
1
Affichages
257
ALS35
A
C
  • Question Question
XL 2021 Mettre en couleur cellule avec une mêmes informations
Réponses
3
Affichages
141
Ckyara31
C
Retour