Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

trier une base pour creer des listes dynamiques

Z

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,

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...
Trier par date Trier par votes

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

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:
Vote positif 0 Vote négatif
Solution
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

G
  • Question
XL 2019 Sélectionner un fichier pour mettre à jour une base de données
Réponses
3
Affichages
175
sylvanu
  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
432
ph.vanne
R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
532
robpellan52
R
  • Résolu(e)
XL 2021 Filtrage que je ne parviens pas à faire
Réponses
6
Affichages
585
Usine à gaz
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
540
Compte Supprimé 979
C
G
  • Résolu(e)
XL 2016 VBA : Copie d'une ligne après application d'un filtre
Réponses
7
Affichages
1 K
gfgghbhg
G
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
  • Question
Autres Simplifier une macro
Réponses
1
Affichages
371
fanch55
S
  • Résolu(e)
XL 2016 Besoin d'aide pour un code d'extraction
Réponses
14
Affichages
546
Phil69970
B
  • Question
Microsoft 365 Colorer les Lignes coller
Réponses
4
Affichages
826
bd.afaf
B
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…