Microsoft 365 Macro Excel pour copier coller des lignes dans des onglets

job75 à dit:

Bonjour Axelle B, bienvenue sur XLD,

Voyez le fichier joint et ces macros (Alt+F11) :

VB:

Sub MAJ_feuilles()
Dim t, P As Range, nf$, d As Object, tablo, i&, a
t = Timer
Set P = Sheets("BDD").[C3].CurrentRegion 'à adapter
nf = UCase(P.Parent.Name)
'---liste des gestionnaires sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = P.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    d(tablo(i, 1)) = ""
Next i
'---suppression des feuilles---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
    If UCase(Sheets(i).Name) <> nf Then Sheets(i).Delete
Next i
If d.Count = 0 Then Exit Sub
a = d.keys
tri a, 0, UBound(a) 'tri alphabétique
'---création des feuilles---
For i = 0 To UBound(a)
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = a(i)
    P.AutoFilter 1, a(i) 'filtre automatique
    P.Copy ActiveSheet.[A1]
    ActiveSheet.Columns.AutoFit 'ajuste les largeurs
Next
P.AutoFilter 'ôte le filtre
Sheets(nf).Activate
MsgBox "Mise à jour des feuilles en " & Format(Timer - t, "0.00 \sec")
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

Testée avec un tableau de 1000 lignes et 50 gestionnaires, la macro s'exécute chez moi en 1,5 seconde.

Edit : bonjour sylvanu.

A+

Cliquez pour agrandir...

sylvanu à dit:

Bonjour Axelle et bienvenu sur XLD,
Un essai en PJ. Par contre on doit dupliquer manuellement les feuilles, avec une par gestionnaire. Mais c'est fait une fois pour toute.
Une feuille doit porter le nom du gestionnaire, tel qu'apparaissant dans la liste.
En A2, on utilise le nom de la feuille comme critère de recherche, avec :

VB:

=DROITE(CELLULE("nomfichier";A1);NBCAR(CELLULE("nomfichier";A1))-TROUVE("]";CELLULE("nomfichier";A1)))

Puis pour la recherche proprement dite on utilise :

Code:

=SI(LIGNES($1:1)<=NB.SI(Feuil1!$C$4:$C$10000;AB!$A$2);INDEX(Feuil1!D$4:D$10;PETITE.VALEUR(SI(Feuil1!$C$4:$C$10000=Feuil1!Criteres;LIGNE(INDIRECT("1:"&LIGNES(Feuil1!$C$4:$C$10000))));LIGNES($1:1)));"")

Formule matricielle, donc à valider par Maj+Ctrl+Entrée.
( J'ai limité à 500 le nombre de contrat possibles par gestionnaires, on peut le tirer pour l'augmenter. )

Cliquez pour agrandir...