VBA - tableau et extraction (en fonction de conditions)
Bonjour,
j'ai une base de donnée de 200 000 lignes et 23 colonnes.
la colonne A comporte les catégories, B les ref, C les prix etc....
j'aimerai extraire de cette BD que certaines catégories vers une feuil2 : trois catégories pour l'exemple catégorie 1,4,5
je souhaite gagner en temps de traitement et optimiser au maximum la macro.
exemple :
feuil1 (BD)
....................................colonne A..............colonne B.............colonne C
ligne 1.........................catégorie.............. ref..........................prix
ligne 2.........................1............................aaa.........................10,00
ligne 3.........................1............................adu.........................40,00
ligne 4.........................2............................ads.........................58,00
ligne 5.........................3............................adf..........................90,00
ligne 6.........................4............................ayu .........................80,00
ligne 7.........................4............................agd..........................60,00
ligne 8.........................5............................aop .........................30,00
feuil2
....................................colonne A..............colonne B.............colonne C
ligne 1.........................catégorie.............. ref..........................prix
ligne 2.........................1............................aaa.........................10,00
ligne 3.........................1............................adu.........................40,00
ligne 6.........................4............................ayu .........................80,00
ligne 7.........................4............................agd..........................60,00
ligne 8.........................5............................aop .........................30,00
J’essaie ce code mais il n'est valable que pour une catégorie (la 1).
Sub test()
Application.ScreenUpdating = False
Dim Table(), Ligne As Long, Colonne As Integer, Counter As Integer, Ws As Worksheet
derniere_ligne = Sheets("Feuil1").Range("A1").End(xlDown).Row
Set Ws = Sheets("Feuil2")
Counter = 0
For Ligne = 1 To derniere_ligne
If Cells(Ligne + 1, "A") = 1 Then
Counter = Counter + 1
ReDim Preserve Table(24, Counter)
For Colonne = 1 To 24
Table(Colonne, Counter) = Cells(Ligne + 1, Colonne)
Next Colonne
End If
Next Ligne
With Ws
.Range(.Cells(1, 1), .Cells(Counter, 24)) = Application.Transpose(Table)
End With
Application.ScreenUpdating = True
End Sub
Merci pour votre aide.
bonsoir,
essaie ceci
Sub test()
Application.ScreenUpdating = False
Dim Table(), Ligne As Long, Colonne As Integer, Counter As Integer, Ws As Worksheet
derniere_ligne = Sheets("Feuil1").Range("A1").End(xlDown).Row
Set Ws = Sheets("Feuil2")
Counter = 0
For Ligne = 1 To derniere_ligne
If Cells(Ligne + 1, "A") = 1 or Cells(Ligne + 1, "A") = 4 or Cells(Ligne + 1, "A") = 5 Then
Counter = Counter + 1
ReDim Preserve Table(24, Counter)
For Colonne = 1 To 24
Table(Colonne, Counter) = Cells(Ligne + 1, Colonne)
Next Colonne
End If
Next Ligne
With Ws
.Range(.Cells(1, 1), .Cells(Counter, 24)) = Application.Transpose(Table)
End With
Application.ScreenUpdating = True
End Subnote que tu peux également utiliser simplement le filtre avancé du menu données pour arriver au même résultat.
Merci, pour votre réponse rapide et elle fonctionne.
Note : je ne suis pas passé par un filtre avancé du menu données sur la BD car j'ai environ 1000 catégories et la sélection est variable environ 200.
Maintenant que le principe fonctionne est il possible de faire ceci sur une plus grande plage de catégorie
car cette ligne va être bien grande quand je choisi 200 catégories (peut être avec des variables?):
If Cells(Ligne + 1, "A") = 1 Or Cells(Ligne + 1, "A") = 4 Or Cells(Ligne + 1, "A") = 5 Then etc
exemple (d’après-ci dessus) :
cat1 = 1
cat2 = 4
cat3 = 5
cat_selection = cat1 or cat2 or cat3
If Cells(Ligne + 1, "A") = categorie_selection then
c'est une idée mais je ne sais pas l’écrire et si c'est faisable...
Merci.
bonsoir,
une adaptation du code
Sub test()
Application.ScreenUpdating = False
Dim Table(), Ligne As Long, Colonne As Integer, Counter As Integer, Ws As Worksheet
derniere_ligne = Sheets("Feuil1").Range("A1").End(xlDown).Row
Set Ws = Sheets("Feuil2")
Counter = 0
v = Array(1, 4, 5) ' mettre les valeurs à sélectionner dans cette liste
For Ligne = 1 To derniere_ligne
For i = LBound(v) To UBound(v)
If Cells(Ligne + 1, "A") = v(i) Then
Counter = Counter + 1
ReDim Preserve Table(24, Counter)
For Colonne = 1 To 24
Table(Colonne, Counter) = Cells(Ligne + 1, Colonne)
Next Colonne
Exit For
End If
Next i
Next Ligne
With Ws
.Range(.Cells(1, 1), .Cells(Counter, 24)) = Application.Transpose(Table)
End With
Application.ScreenUpdating = True
End SubBonjour,
Avec une fonction Filtre clé multiple .
Voir si plus rapide pour 200.000 lignes( N'utilise pas Transpose() qui pose des pb si 65.000 lignes sur certaines versions).
Sub EssaifiltreArrayFonctionCol()
Set f = Sheets("bd")
Tbl1 = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
Tbl = FiltreArrayCléColRécup(Tbl1, Array(1, 4, 5), 1, Array(1, 2, 3))
If Not IsEmpty(Tbl) Then Sheets("Résultat").[A2].Resize(UBound(Tbl), UBound(Tbl, 2) - LBound(Tbl, 2) + 1) = Tbl
End Sub
Option Compare Text
Function FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)
n = 0
For i = 1 To UBound(Tbl)
témoin = False
For Each c In clé
If Tbl(i, colClé) = c Then témoin = True
Next c
If témoin Then n = n + 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
témoin = False
For Each c In clé
If Tbl(i, colClé) = c Then témoin = True
Next c
If témoin Then
n = n + 1
For k = LBound(colRécup) To UBound(colRécup): Tbl2(n, k) = Tbl(i, colRécup(k)): Next k
End If
Next i
If n > 0 Then FiltreArrayCléColRécup = Tbl2
End FunctionBonsoir,
Nouvelle version + rapide
Option Compare Text
Function FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)
n = 0
Set d = CreateObject("scripting.dictionary")
For Each c In clé: d(c) = "": Next c
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then n = n + 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then
n = n + 1
For k = LBound(colRécup) To UBound(colRécup): Tbl2(n, k) = Tbl(i, colRécup(k)): Next k
End If
Next i
If n > 0 Then FiltreArrayCléColRécup = Tbl2
End FunctionBoisgontier
Bonjour à tous,
Je propose une autre alternative utilisant du Sql, avec une démo de 6000 lignes de données fictives.
En Feuil2 un textbox dans laquelle on saisit les catégories à sélectionner en les séparant par une virgule, puis bouton "Go"
Pierre
Sub Extraire()
Dim Hd As String, S As Variant, Cnd As String, i As Integer, T As Variant
Hd = Sheets("Feuil1").Range("A1").Value
S = Split(Replace(Sheets("Feuil2").TextBox1.Value, " ", ""), ",")
For i = 0 To UBound(S)
Cnd = Cnd & "`" & Hd & "`=" & S(i) & " OR "
Next i
Req = "SELECT * FROM " & Tbl_Bdd & " WHERE " & Left(Cnd, Len(Cnd) - 3)
Connect_xls ThisWorkbook.Path & "\" & ThisWorkbook.Name
T = Select_Db(Req, 1)
Close_Cnx
Sheets("Feuil2").Range("A2:Z20000").ClearContents
Sheets("Feuil2").Range("A2").Resize(UBound(T, 1), UBound(T, 2)) = T
End SubBonjour,
Pour BD de 20.000 lignes et 20 catégories: 0,03 seconde
Boisgontier
En version XLM (il suffit de changer 65000 par 1000000) , pour BD 100.000 lignes et 200 catégories, on obtient un temps de 0,15 sec
(Avec la requête SQL de pierrep56, BD de 6.000 lignes et 5 catégories, on obtient 0,14 sec)
Sub EssaifiltreArrayFonctionCol()
t = Timer()
Set f = Sheets("bd")
Tbl1 = f.Range("A2:C" & f.[A1000000].End(xlUp).Row).Value
Dim TblCaté(1 To 200)
For i = 1 To 200: TblCaté(i) = i: Next i
Tbl = FiltreArrayCléColRécup(Tbl1, TblCaté, 1, Array(1, 2, 3))
If Not IsEmpty(Tbl) Then Sheets("Résultat").[A2].Resize(UBound(Tbl), UBound(Tbl, 2) - LBound(Tbl, 2) + 1) = Tbl
MsgBox Timer - t ' 0,10 sec pour BD 70.000 lignes et 200 catégories
End Sub
Option Compare Text
Function FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)
n = 0
Set d = CreateObject("scripting.dictionary")
For Each c In clé: d(c) = "": Next c
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then n = n + 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then
n = n + 1
For k = LBound(colRécup) To UBound(colRécup): Tbl2(n, k) = Tbl(i, colRécup(k)): Next k
End If
Next i
If n > 0 Then FiltreArrayCléColRécup = Tbl2
End FunctionBoisgontier
Bonjour et merci toutes vos réponses.
J'ai essayé toutes vos solutions.
La solution de Boisgontierjacques est en effet très rapide.
Est-il possible de modifier le code pour ne pas sélectionner les 200 catégories qui vont de 1 à 200 mais de pouvoir choisir le numéro des catégories exemple 1,2,5,250,360,480 avec certainement 200 catégories sélectionnées.
-> Dim TblCaté(1 To 200)
-> For i = 1 To 200: TblCaté(i) = i: Next i
Sub EssaifiltreArrayFonctionCol()
T = Timer()
Set F = Sheets("Feuil1")
Tbl1 = F.Range("A2:W" & F.[A1000000].End(xlUp).Row).Value
Dim TblCaté(1 To 200)
For i = 1 To 200: TblCaté(i) = i: Next i
Tbl = FiltreArrayCléColRécup(Tbl1, TblCaté, 1, Array(1, 6, 7, 8, 14, 16, 17, 18))
If Not IsEmpty(Tbl) Then Sheets("Feuil2").[A2].Resize(UBound(Tbl), UBound(Tbl, 2) - LBound(Tbl, 2) + 1) = Tbl
MsgBox Timer - T
End Sub
Option Compare Text
Function FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup)
n = 0
Set d = CreateObject("scripting.dictionary")
For Each C In clé: d(C) = "": Next C
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then n = n + 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then
n = n + 1
For k = LBound(colRécup) To UBound(colRécup): Tbl2(n, k) = Tbl(i, colRécup(k)): Next k
End If
Next i
If n > 0 Then FiltreArrayCléColRécup = Tbl2
End Function
Bonjour,
Version avec formulaire pour choisir les catégories.
Boisgontier
Merci pour votre réponse, elle fonctionne bien.
Pour le choix des catégories
Je dois faire cette manipulation tous les jours avec un choix de 200 catégories qui resteront les mêmes.
Es-ce possible de ne pas passer par une checkbox (200clics) mais d'indiquer seulement les catégories qui m’intéressent dans une feuille, pour que ça soit plus rapide.
C'est parfait.
merci bcp!
En conservant le dernier fichier reçu.
J'ai ajouté le nom des catégories dans la feuille Caté
(voir le fichier en pièce jointe ce sera peut être plus explicite)
Es-ce possible
D'ajouter les quatre premiers caractères du nom de la catégorie au début de la référence
Supprimer la colonne catégorie
Déplacer la colonne prix après la colonnes xxxx
Merci.
Bonjour,
Je ne connais que les fichiers .zip
Boisgontier
j'ai reposté avec le fichier en zip.
Ça fonctionne pour la caté1
en reprenant le dernier fichier es-ce possible de
- conserver les deux boutons de la BD
1 bouton pour le choix des catégories
1 bouton pour les catégories déjà défini (caté1)
dans la feuille CATE d'avoir :
le numéro des catégories en A et le nom en B
le numéro des catégories1 en C et le nom en D
Merci
J'ai mis a jour le fichier ce sera peut être plus simple.
Feuille CATE
j'ai conservé le choix des catégories avec nom en A en numéro en B.
Feuil BD
En appuyant sur le bouton Go caté1 / résultat ça fonctionne parfaitement avec envoi vers RESULTAT1.
En appuyant sur le bouton Go choix caté / résultat2 cela ne fonctionne pas avec envoi vers RESULTAT2 (je n'arrive pas a résoudre).
En appuyant sur Go caté1 / résultat, j’aimerai aussi pouvoir traiter les doublons de RESULTAT1.
Il faudrait que la quantité (C) des doublons refs (A) soit cumulé avec suppression des doublons.
exemple :
doublon de la ref ROBE05.018-210 en A en ligne 4,5,6 -> au final une seul ref avec le stock ajouté
avant :
A........................................B..............................C
GABR05.010-8..................COUPELLE..............12
GABR05.017-10X1.5........ACCESSOIRES...........233
ROBE05.018-210..............ACCESSOIRE..............7
ROBE05.018-210..............ACCESSOIRE..............70
ROBE05.018-210..............ACCESSOIRE..............5
ATNO05.018-217..............ACCESSOIRE..............1
ATNO05.018-219..............ACCESSOIRE..............10
après:
GABR05.010-8..................COUPELLE..............12
GABR05.017-10X1.5........ACCESSOIRES...........233
ROBE05.018-210..........ACCESSOIRE.............82
ATNO05.018-217..............ACCESSOIRE..............1
ATNO05.018-219..............ACCESSOIRE..............10
En appuyant sur Go caté1 / résultat dans BD, j'aimerai pouvoir calculer le nombre de mois selon la date Q R S a aujourd'hui avec ces règles.
si Q est vide et R n'est pas vide S n'est pas vide alors R à aujourd'hui avec nombre de mois en X
si Q n'est pas vide et R n'est pas vide S n'est pas vide alors Q à aujourd'hui avec nombre de mois en X
si Q vide et R n'est pas vide S vide alors R à aujourd'hui avec nombre de mois en X
Merci pour votre aide.