trier une base pour creer des listes dynamiques

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 !

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...
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

Dernière édition:
- 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éponses
10
Affichages
455
Réponses
1
Affichages
376
Réponses
4
Affichages
832
Réponses
1
Affichages
435
  • Question Question
Microsoft 365 colorer une plage
Réponses
2
Affichages
827
  • Question Question
Microsoft 365 Copie des données
Réponses
0
Affichages
579
Retour