Appliquer la même macro sur plusieurs feuilles

Bonjour,

j'ai la macro suivante qui extrait d'un onglet source les lignes qui commencent par 10CD et qui les copie sur l'onglet 10CD.

Sub Dispatch()
  Dim Lig As Long
  Dim Col As String
  Dim NbrLig  As Long
  Dim NumLig  As Long

Sheets("10CD").Activate
  dl = Range("A65536").End(xlUp).Row
  Rows("2:" & dl).Select
  Selection.Delete Shift:=xlUp
  Col = "A"
  NumLig = 1
  With Sheets("Source")
  NbrLig = .Cells(65536, Col).End(xlUp).Row
  For Lig = 1 To NbrLig
    If .Cells(Lig, Col).Value = "10CD" Then
      .Cells(Lig, Col).EntireRow.Copy
      NumLig = NumLig + 1
      Cells(NumLig, 1).Select
      ActiveSheet.Paste
    End If
  Next
  End With
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
End Sub

Mon problème est que j'aimerai que cette macro sélectionne aussi les lignes qui commencent par 10DG et les copie sur l'onglet 10DG, les lignes qui commencent par 20BC et les copie sur l'onglet 20BC, les lignes qui commencent par 30MG et les copie sur l'onglet 30MG.

En tout, j'ai pour l'instant 16 onglets, positionnés en 3 à 18, et qui commencent pas un chiffre de 1 à 3 puis un 0 puis deux lettres.

Merci pour votre aide.

Bonjour,

Suite à la copie, est-ce que tu supprimes les données de l'onglet "Source", ou tu mets tout à suivre?

Peux-tu joindre un fichier, avec une dizaine de lignes représentatives, et comprenant 2 ou 3 onglets, avec leur vrai nom?

Données anonymes, bien sûr

@ te relire

Bonjour,

Mets un fichier en ligne ce sera plus facile de te donner le code correct.

Amicalement

Edit : oups... Salut Cousinhub. j'avais pas vérifié avant de poster

Voici un fichier simplifié où :

1er onglet : Calcul : calcul des volumes + boutons de traitement

2ème onglet : Source : fichier source importer d'une base et d'où sont extraites les données à dispatcher dans les autres onglets

Onglets suivants : chaque onglet porte le code de chaque agent qui retrouvera ses informations

Si vous avez besoin d'autres précisions ...

Par avance, merci.

Re-,

regarde le fichier joint

le code :

Sub dispatcher()
Dim LesAgents As Object
Dim Cel As Range
Dim Sh As Worksheet
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> "Calcul" And Sh.Name <> "Source" Then Sh.Delete
Next Sh
Set LesAgents = CreateObject("Scripting.Dictionary")
With Sheets("Source")
    .Range("A1:L" & .[A65000].End(xlUp).Row).Name = "base"
    .[Z1] = .[A1]
    For Each Cel In .Range("a2", .[A65000].End(xlUp))
        LesAgents(Cel.Value) = Cel.Value
    Next Cel
    For Each it In LesAgents.Items
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = it
        .[Z2] = it
        .Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), _
            CopyToRange:=Range("A1"), Unique:=False
    Next it
    .[Z1:Z2].Clear
    .Select
End With
End Sub

Fichier :

Salut cousinhub,

ton zip est vide, est-ce normal ?

Pour le reste je vais étudier, comprendre et tester ton code.

Déjà merci.

*** Edit : pour l'instant cela donne le résultat voulu. Merci !

Re-,

ton zip est vide, est-ce normal ?

Euh, ben non, sinon je ne l'aurai pas mis....

Je viens de le télécharger, et c'est OK???

M'enfin, si tu as pu tester le code, c'est le principal

Bonne journée

Et j'allais oublier de saluer Dan, Bonjour!

C'est bon, j'ai pu voir le zip.

Merci à toi, et à ceux qui se sont penchés sur le problème.