Macro : filtre autant qu'il y a de nom et copier coller dans autant d'onglet

[jerome91]

Bonjour,
J'ai une base de données avec le nom d'agence, le nom de collaborateur et salaires. Une agence peut avoir plusieurs collaborateurs.
J'ai réussi à créer une macro via l'enregistreur pour faire un filtre dans la colonne A (agence) et ensuite faire un copier coller dans un autre onglet.
Hors je voudrais que le filtre se fasse de façon automatique à chaque changement de nom d'agence, il peut y en avoir un x nombre et ensuite copier coller dans x onglet les données.
Pourriez-vous m'aider ?
Merci.
Jérôme

 

[job75]

Bonjour jerome91,

Cette macro dans le code de la feuille "Base" crée les onglets des agences :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, a, i%, x$, j%
Set r = Intersect(Target, Range("A2:D" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Set r = Intersect(r.EntireRow, [A:A])
'---liste sans doublon des agences de Target---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r 'si entrées multiples (copier-coller)
  If r <> "" Then d(r.Value) = ""
Next r
If d.Count = 0 Then Exit Sub
a = d.keys
'---création des feuilles---
On Error Resume Next
For i = 0 To UBound(a)
  If IsError(Sheets(a(i))) Then
    Application.ScreenUpdating = False
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = CStr(a(i))
  End If
Next i
'---classement des onglets créés---
If Not Application.ScreenUpdating Then
  For i = 2 To Sheets.Count 'on ne touche pas au 1er onglet
  x = LCase(Sheets(i).Name)
  For j = i + 1 To Sheets.Count
  If LCase(Sheets(j).Name) < x Then Sheets(j).Move Before:=Sheets(i)
  Next j, i
  Me.Activate
End If
End Sub

Et celle-ci dans ThisWorkbook met les feuilles à jour quand on les active :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
With Sheets("Base")
  If Sh.Name = .Name Then Exit Sub
  Application.ScreenUpdating = False
  If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
  Cells.Delete 'RAZ
  .[E2] = "=A2=""" & Sh.Name & """" 'critère de filtrage
  .UsedRange.Resize(, 4).AdvancedFilter xlFilterCopy, .[E1:E2], Sh.[A1]
  .[E2] = ""
  Sh.Columns.AutoFit 'ajustement largeurs
End With
End Sub

C'est le filtre avancé qui est utilisé.

Pour un bon classement des onglets la feuille "Base" doit toujours être la 1ère feuille.

Edit : il ne faut pas de caractères interdits [ ] \ / : * ? dans les noms des agences.

Et les noms ne doivent pas avoir plus de 31 caractères.

A+

 

[job75]

Re,

Pour retirer les onglets des agences indésirables ou entrées par erreur :

Sub Retirer()
'se lance par Ctrl+R
Dim i%
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
  If Application.CountIf([A:A], Sheets(i).Name) = 0 Then Sheets(i).Delete
Next
End Sub

Fichier (2).

A+

 

[jerome91]

Merci