Créer onglets selon modalités

Bonjour,

J'ai une base de données de presque 30000 lignes à retraiter selon les normes postales par pays. Vu que je ne peux pas "créer" une formule passe-partout qui correspond à chaque pays, j'ai eu l'idée d'extraire la base de données en onglet, où un onglet = un pays afin de créer plus simplement les mises en forme postales par pays...

Seulement, je bloque et je sais pas comment m'y prendre pour dire dans une macro "Extrais-moi dans autant d'onglets qu'il y a de pays en colonne D, les lignes correspondantes à chacun"...

Par exemple, dans le fichier joint, dans l'onglet "FRANCE", j'aurais 3 lignes... Dans l'onglet "AUTRICHE", une seule.

Merci par avance de votre aide !

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Salut !

C'est super !!!! Merci énormément. Je l'ai adapté à mon vrai fichier, c'est une vraie merveille

Bonjour,

comme ceci alors

P.

edit: test d'existence de l'onglet du pays

Hello à mes camarades de classe

Option Explicit
Sub SPLIT_EN_ONGLET_RAPIDE()
Dim Bd, A, i, k, D, T, f, mCode
Set f = Sheets("données")            ' codename de la feuil1 (au cas d'un changement de nom)  ici feuil1 est celle de départ
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Bd = f.Range("A2:D" & f.[A65000].End(xlUp).Row)  ' on met dans une base de données
Set D = CreateObject("scripting.dictionary")  ' on scanne la base de données et la mets dans un dictionnaire (+ rapide)
For i = 1 To UBound(Bd): D(Bd(i, 4)) = D(Bd(i, 4)) & i & ",": Next  ' dictionnaire
' on splitte ici sur la colonne D
For Each k In D.Keys
  On Error Resume Next
  If Not WorksheetExists(UCase(k)) Then
    Sheets.Add after:=Sheets(Sheets.Count)  ' ajout d'une feuille
    ActiveSheet.Name = UCase(k)             ' on nomme la feuille comme chacune des différentes occurences de la colonne D
  End If
  On Error GoTo 0
' on reprends toutes les données d'une même occurence pour les coller en A2 d'une nouvelle feuille
  A = Application.Index(Bd, Application.Transpose(Split(D.Item(k), ",")), _
                        Application.Transpose(Evaluate("Row(1:" & UBound(Bd, 2) & ")")))  ' extraction array()
  Sheets(k).[A2].Resize(UBound(A) - 1, UBound(A, 2)) = A
  Feuil1.[A1:D1].Copy Sheets(k).[A1]           'copie des titres vers la nouvelle feuille
Next k
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
Dim Sht As Worksheet
WorksheetExists = False
For Each Sht In ActiveWorkbook.Worksheets
  If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
End Function

Bonjour,

Autre essai à tester.

Cordialement.

En complément, je conseille de mesurer la durée d'exécution de chaque méthode...

Intéressant !