Résolu Résolu trier une base pour creer des listes dynamiques

Zilba456

XLDnaute Nouveau
Supporter XLD
bonjour j'ai creer une macro pour trier et copier du texte dans une nouvelle feuille afin de pouvoir creer des listes déroulantes qui ce mettrons à jour à chaque démarrage du classeur.
La procédure est relativement lente !
VB:
Sub Liste()
'
' Liste Macro
'

'trier la source par critère et la coller dans la feuille liste par catégorie afin d'avoir une base pour creer des liste déroulante mise a jour
'par l'ajout d'un nouvelle article en mettant la macro dans l'ouverture du classeur
'
'

    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="sac a dos"
    Columns("a").Select
    Selection.Copy
    Sheets("liste").Select
    Range("A2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="pochettes"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("B2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="liner"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("C2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="sac etanche"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("D2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="tente"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("E2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="sol"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("f2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="piquets"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("G2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="haubans"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("H2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="sursac"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("i2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="sac de couchages"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("j2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="drap"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("k2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="matelas"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("l2").Select
    ActiveSheet.Paste
    Sheets("Matos").Select
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2
    ActiveSheet.ListObjects("Tsource").Range.AutoFilter Field:=2, Criteria1:="bouteille"
    Columns("a").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("M2").Select
    ActiveSheet.Paste
    Rows("2,0").Delete
End Sub
as-t-il un moyen de simplifié ce code ?
je débute en Vba!
 
Ce fil a été résolu! Aller à la solution…

BOISGONTIER

XLDnaute Barbatruc
Bonjour,

Sans titre.png cf pj


Tri et nomme les listes


VB:
Sub gListes()
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To [tsource].Rows.Count
     clé = [tsource].Item(i, 2)
     Item = [tsource].Item(i, 1)
     d(clé) = d(clé) & Item & "|"
  Next i
  col = 5
  Cells(1, col).Resize(, d.Count) = d.keys
  For Each k In d.keys
    tmp = d(k)
    a = Split(tmp, "|")
    Cells(2, col).Resize(UBound(a)) = Application.Transpose(a)
    Cells(2, col).Resize(UBound(a)).Sort key1:=Cells(2, col), Header:=xlNo
    ActiveWorkbook.Names.Add Name:=Replace(k, " ", "_"), RefersTo:=Cells(2, col).Resize(UBound(a))
    col = col + 1
  Next k
End Sub
Crée des listes sous forme de tableaux nommés


Boisgontier
 
Ce message a été identifié comme étant une solution!

Fichiers joints

Dernière édition:

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas