Macro trop longue

[lili_alex]

Bonjour à tous
J'ai un petit problème que j'aimerai bien qu'on m'aide à résoudre.
Voilà j'ai fait une macro mais elle est trop longue et je en sais pas comment la simplifier.
Je fais toujours la même fonction mais dans presque 50 classeurs différents : cette fonction est de copier certaines données de chaque classeur et de les mettre dans un seul classeur.
Voici la macro (je ne vous fais voir que le début) :


Application.ScreenUpdating = False
Sheets("Feuil1").Select
Range("A19").Select
Range("A19:O19").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A19").Select
ChDir _
"D:\documents and Settings\90031689\My Documents"
Workbooks.Open Filename:= _
"D:\documents and Settings\90031689\My Documents\Argentina.xls"
Range("A19").Select
If Range("A19").Formula = "" Then
Windows("Argentina.xls").Activate
ActiveWindow.Close
ElseIf Range("A20").Formula = "" Then
Range("A19:O19").Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Windows("Argentina.xls").Activate
ActiveWindow.Close
Else
Range("A19:O19").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("Argentina.xls").Activate
ActiveWindow.Close
End If
Workbooks.Open Filename:= _
"D:\documents and Settings\90031689\My Documents\Algeria.xls"
Range("A19").Select
If Range("A19").Formula = "" Then
Windows("Algeria.xls").Activate
ActiveWindow.Close
ElseIf Range("A20").Formula = "" Then
Range("A19:O19").Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Windows("Algeria.xls").Activate
ActiveWindow.Close
Else
Range("A19:O19").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("Algeria.xls").Activate
ActiveWindow.Close
End If
Workbooks.Open Filename:= _
"D:\documents and Settings\90031689\My Documents\Armenia.xls"
Range("A19").Select
If Range("A19").Formula = "" Then
Windows("Armenia.xls").Activate
ActiveWindow.Close
ElseIf Range("A20").Formula = "" Then
Range("A19:O19").Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Windows("Armenia.xls").Activate
ActiveWindow.Close
Else
Range("A19:O19").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Windows("Armenia.xls").Activate
ActiveWindow.Close
End If
Application.ScreenUpdating = True
End Sub


Si quelqu'un peut m'aider.
Merci d'avance.

 

[JYLL]

Re : Macro trop longue

Bonjour Lili-Alex et le Forum,

Voici ta macro raccourcie, j'espère que cela répondra à ton besoin. Il te reste à mettre les nom entre guillemets dansle tableau et la macro s'adapte au nombre de pays.

 '################# Déclaration des variables utilisées ######################
Dim Classeurs As Variant, Pointeur As Integer
 '################# Mettre entre guillemets les noms des pays ##################
 '
    Classeurs = Array("Argentina", "Algeria", "Armenia")
 '
    Application.ScreenUpdating = False
    Sheets("Feuil1").Select
    Range("A19:O19").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A19").Select
    '################# On se place dans le bon répertoire######################
    '
    ChDir "D:\documents and Settings\90031689\My Documents"
    '
    '################# Début de la boucle qui évite la répétition des ligne #############
    '
    Pointeur = 1
    While Pointeur <= UBound(Classeurs, 1)
        Workbooks.Open Filename:=Classeurs(Pointeur) & ".xls"
        Range("A19").Select
        If Range("A19").Formula = "" Then
            '
            '#################Utilisation du nom du classeur contenu dans le tableau "Classeurs"#####
            '
            Windows(Classeurs(Pointeur) & ".xls").Activate
            ActiveWindow.Close
        ElseIf Range("A20").Formula = "" Then
            Range("A19:O19").Select
            Selection.Copy
            Windows("Recap.xls").Activate
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            ActiveCell.Offset(1, 0).Select
            Windows(Classeurs(Pointeur) & ".xls").Activate
            ActiveWindow.Close
        Else
            Range("A19:O19").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Windows("Recap.xls").Activate
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Selection.End(xlDown).Select
            ActiveCell.Offset(1, 0).Select
            Windows(Classeurs(Pointeur) & ".xls").Activate
            ActiveWindow.Close
        End If
        Pointeur = Pointeur + 1
    Wend
    Application.ScreenUpdating = True
End Sub

Bon test.

 

[Catrice]

Re : Macro trop longue

Bonsoir,

Encore un peu de compression de code à partir de celle de Jyll (non testé) :

Dim Classeurs As Variant, Pointeur As Integer
Classeurs = Array("Argentina", "Algeria", "Armenia")
Sheets("Feuil1").Range(Range("A19:O19"), Range("A19:O19").End(xlDown)).ClearContents
Range("A19").Select
ChDir "D:\documents and Settings\90031689\My Documents"
Pointeur = 1
While Pointeur <= UBound(Classeurs, 1)
Workbooks.Open Filename:=Classeurs(Pointeur) & ".xls"
If Range("A19").Formula = "" Then
Windows(Classeurs(Pointeur) & ".xls").Close
ElseIf Range("A20").Formula = "" Then
Range("A19:O19").Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Windows(Classeurs(Pointeur) & ".xls").Close
Else
Range(Range("A19:O19"), Range("A19:O19").End(xlDown)).Copy
Windows("Recap.xls").Activate
Selection.PasteSpecial Paste:=xlPasteValues
Selection.End(xlDown).Offset(1, 0).Select
Windows(Classeurs(Pointeur) & ".xls").Close
End If
Pointeur = Pointeur + 1
Wend
Application.ScreenUpdating = True
End Sub

 

[lili_alex]

Re : Macro trop longue

Merci c'est super gentil à vous deux.
Passez un bon week end.
A très bientôt