recopiage et classement par mois

[matt31]

Bonjour à tout le monde.

Je demande de l'aide pour une macro que je n'arrive pas à faire.
J'utilise un fichier différent pour chaque semaine de l'année (EM 141 - S 01 en pièce jointe). Je voudrais recopier de manière automatique toutes les données présentes sur ce fichier sur un fichier récapitulatif (dossiers annuels - EM 141 en pièce jointe).
J'ai essayé de faire une macro pour cela mais je n'y arrive pas sans arriver à trouver la source du problème.

D'autre part, je voudrais récupérer les données des 52 fichiers semaine mais chacun a un nom différent (EM 141 - S 01 à S 52). Je ne sais pas comment faire pour avoir une cible différente.

Dernière demande, je voudrais que dans le fichier récapitulatif les dossiers du mois de janvier aillent ensuite sur une feuille janvier et ainsi pour chaque mois.

Je vous remercie pour votre aide.

 

[phlaurent55]

Re : recopiage et classement par mois

Bonjour matt,

essaie ceci:
les modifs faites se trouvent entre les lignes
'+++++++++++++++++++++++++++++++++++

Sub Recap()

Dim DerLig1 As Integer, DerLig2 As Integer, i As Integer, Réf_VaR As Long, k As Integer, l As Integer
Dim Colonne_O As String, Colonne_P As String, Colonne_Q As String, Colonne_R As String, Chemin As String, Nom_de_ce_fichier As String

Application.ScreenUpdating = False

Nom_de_ce_fichier = ThisWorkbook.Name
Chemin = ThisWorkbook.Path

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
For j = 1 To 52
Workbooks.Open Filename:=Chemin & "\EM 141 - S " & Right("0" & CStr(j), 2) & ".xls"
Windows("EM 141 - S " & Right("0" & CStr(j), 2) & ".xls").Activate
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

DerLig1 = Range("C" & Rows.Count).End(xlUp).Row

'copie des dossiers sur le fichier de dossiers annuels
For i = 3 To DerLig1
    Range("A" & i & ":Y" & i).Copy
    Windows(Nom_de_ce_fichier).Activate
    DerLig2 = Range("C" & Rows.Count).End(xlUp).Row
    Range("A" & DerLig2 + 1).PasteSpecial

Next

'tri fichier dossiers annuels
Windows(Nom_de_ce_fichier).Activate
DerLig2 = Range("C" & Rows.Count).End(xlUp).Row
Rows("2:" & DerLig2).Select
Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
          
'suppression des doublons du fichier dossiers annuels pour qu'ils n'apparaissent qu'une fois
Cells(4, 3).Activate
Do Until ActiveCell = ""
    If ActiveCell = ActiveCell.Offset(-1, 0) Then
        ActiveCell.Offset(-1, 0).EntireRow.Delete
        ActiveCell.Activate
    End If
    ActiveCell.Offset(1, 0).Activate
Loop

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Windows("EM 141 - S " & Right("0" & CStr(j), 2) & ".xls").Close
Next j
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

End Sub

il subsiste un problème avec le calcul de la position de la dernière ligne avant copiage
je te laisse le résoudre
......... pas testé avec les 52 fichiers

à+
Philippe

 

[matt31]

Re : recopiage et classement par mois

merci, ça marche impecc avec les 52 fichiers semaine.

J'ai toujours le bug lors du copiage et toujours aucune idée du problème. si quelqu'un a le temps d'y jeter un coup d'oeil et de m'aider, je suis preneur.
Merci par avance

 

[matt31]

Re : recopiage et classement par mois

bonsoir à tout le monde.

Toujours bloqué, je suis preneur de toute aide...

Merci d'avance