Macro mets 30 min à tourner

c'est bizarre chez toi ça marche super bien c'est exactement ce qu'il me faut comme résultat.

ça te dérange pas de partager avec moi la macro qui t'as permis d'avoir ce fichier ?

Merci d'avance.

Cdt

Hajar

Bonjour,

ça te dérange pas de partager avec moi la macro qui t'as permis d'avoir ce fichier ?

mais c'est exactement celle que j'ai posté dans un des posts précédents et c'est celle-ci dessous :

Sub Archiver()

    Dim wk1 As Workbook
    Dim wk2 As Workbook
    Dim CC As Workbook
    Dim Plage As Range
    Dim PlgVal As Range
    Dim Cel As Range
    Dim TblFe
    Dim Chemin As String, extension As String, Pays As String
    Dim n As Integer
    Dim Debut As Date
    Dim Adr As String
    Dim Lgn As Long
    Dim I As Integer

    Debut = Time 'pour la mesure du temps d'exécution

    Application.ScreenUpdating = False

    Set wk1 = ThisWorkbook
    Set wk2 = Workbooks("Pays test macro.xlsx") '<--- il doit être ouvert !

    Chemin = ThisWorkbook.Path & "\"
    extension = ".xlsx"

    'ici, adapter les noms des feuilles !
    TblFe = Array("Feuille 2", "Feuille 3") '<------ !!!

    For n = 4 To 77

        Pays = wk1.Sheets("Feuil1").Range("A" & n)

        'supprime les valeurs et formules des feuilles du classeur "Pays test macro.xlsx"
        wk2.Worksheets("Feuille 1").Rows(6).ClearContents
        wk2.Worksheets("Feuille 2").Rows("6:25").ClearContents
        wk2.Worksheets("Feuille 3").Rows("6:25").ClearContents

        If Pays <> "" Then

    '----feuille "Feuille 1"-----
           With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With

            'recherche exacte sur la colonne A
            Set Cel = Plage.Find(Pays, , xlValues, xlWhole)

            'si trouvé...
            If Not Cel Is Nothing Then

                With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
                With wk2.Worksheets("Feuille 1"): .Range(.Cells(6, 1), .Cells(6, PlgVal.Columns.Count)).Value = PlgVal.Value: End With

            End If

            For I = 0 To UBound(TblFe)

    '----autres feuilles dont les noms sont dans le tableau "TblFe"-----
               With Workbooks("Final.xlsx").Worksheets(TblFe(I)): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With

                'recherche partielle sur la colonne A
                Set Cel = Plage.Find(Pays, , xlValues, xlPart)

                'si trouvé...
                If Not Cel Is Nothing Then

                    Adr = Cel.Address

                    Do

                        With Workbooks("Final.xlsx").Worksheets(TblFe(I)): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With

                        With wk2.Worksheets(TblFe(I))

                            Lgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                            If Lgn < 6 Then Lgn = 6
                            .Range(.Cells(Lgn, 1), .Cells(Lgn, PlgVal.Columns.Count)).Value = PlgVal.Value

                        End With

                        Set Cel = Plage.FindNext(Cel)

                    Loop While Cel.Address <> Adr

                End If

            Next I

            'adapter les noms des feuilles ici aussi !!!
            wk2.Worksheets(Array("Feuille 1", "Feuille 2", "Feuille 3")).Copy

            ActiveWorkbook.SaveAs Chemin & "Test_" & Pays & extension, 51
            ActiveWorkbook.Close True

        End If

    Next n

    Application.ScreenUpdating = True

    'affiche le temps d'exécution
    MsgBox Format(Time - Debut, "hh:mm:ss")

End Sub

Si tu n'y arrives pas, il faudrait que tu postes des classeurs qui soient vraiment représentatifs des classeurs réels donc, tu laisses les valeurs numériques et les noms des feuilles mais tu modifies toutes les valeurs comme les noms de famille ou de société, les prénoms, les adresses, les numéros de téléphone et dans le cas où il y aurait des milliers de lignes ou colonnes, il te suffit d'en laisser que 300 ou 4oo car pour les tests, on peut toujours dupliquer

bonjour

je vous assure que c'est la même que je vous ai envoyé quand j'essaie votre code ça me supprime les données dans les deux derniers onglets sans faire de recherche comme c'est écrit dans le fichier initial..

je vous reposte les fichiers au cas où

merci d'avance

Cdt

Hajar

Bonsoir,

Je regarde ça demain !

Bonjour,

Je vois que tu m'as renvoyé les mêmes classeurs et ma réponse sera donc la même les 74 classeurs sont créés en moins de 30 secondes et avec les valeurs correspondantes ! A ce stade, je ne peux rien faire de plus désolé !

Je te joins 3 classeurs test pour que tu puisses vérifier, allez, je t'en joins 4

ok merci pour ton aide