trier une base pour creer des listes dynamiques

Zilba456

XLDnaute Nouveau
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!
 
Solution
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...

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
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
 

Pièces jointes

  • GenereListes.xlsm
    19.2 KB · Affichages: 6
Dernière édition:

Discussions similaires

Réponses
4
Affichages
556
Réponses
2
Affichages
655

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG