Macro inachevée

"Df = ActiveWorkbook.Sheets.Count

        f = Df

Do

    If Not (Right(Sheets(f).Name, 4) Like An) Then

        SendKeys ("{ENTER}")

        Sheets(f).Delete

    Else

        df0 = Df - 1

    End If

        f = f - 1

Loop While (df0 > 0 Or IsNull(df0) Or IsEmpty(df0)) And f > 0   "

"Sub StatAgendaRegrouptCahier()    

    Df = ActiveWorkbook.Sheets.Count

    DM = Worksheets(Df).Name

    Mois = Right(DM, 2)

    An = Left(Right(DM, 7), 4)

    DM = Right(DM, 7)    

    SendKeys ("{LEFT}{ENTER}")

    ActiveWorkbook.SaveAs Filename:= _

        "D:\D-Mes documents\Cs4_GENERALES\Docts" & An & "\StatsCs\RecapStatCs" & An & "-" & Mois & ".xls" _

        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False    

    f = 1   ' f = Index feuille courante

    NoP1 = 0    ' NoP1 = Index feuille recapitulative

Do

        Worksheets(f).Activate

        NF = Worksheets(f).Name     '   NF = Nom feuille courante, Index (f)        

If Left(NF, 3) = Mid(Cells(2, 2), 8, 3) And Not (IsNull(NFN) Or IsEmpty(NFN)) Then

'     si 3_1er caractères du nom de la feuille courante = n°UH de cellule UH

        Cells(2, 1).Select

    If IsEmpty(Cells(3, 1)) Then

        Range(Cells(2, 1), Cells(2, 9)).Select  'Selectionne la ligne entière

    Else

        SelectPave   'Selectionne une plage entière

    End If    

        Selection.Copy

        Sheets(NFN).Select

        Cells(l + 1, 1).Select

        ActiveSheet.Paste

        l = Cells(1, 1).End(xlDown).Row

Else

        NFN = Left(Cells(2, 2), 4) & "#" & Mid(Cells(2, 2), 8, 3) & "#" & Mid(Cells(2, 2), 14, 25) & "#" & An

        NFN = IIf(Len(NFN) < 32, NFN, Left(NFN, 26) & Right(NFN, 5))

        Sheets(NoP1 + 1).Select

        Sheets.Add

        ActiveSheet.Name = NFN

        f = f + 1

        NoP1 = Worksheets(NFN).Index

        Sheets(f).Select

        Cells(1, 1).Select

        SelectPave

        Selection.Copy

        Sheets(NoP1).Select

        ActiveSheet.Paste

        l = Cells(1, 1).End(xlDown).Row

        Df = Df + 1

End If

        f = f + 1

Loop While f < Df + 1



        Df = ActiveWorkbook.Sheets.Count

        f = Df

Do

    If Not (Right(Sheets(f).Name, 4) Like An) Then

        SendKeys ("{ENTER}")

        Sheets(f).Delete

    Else

        df0 = Df - 1

    End If

        f = f - 1

Loop While (df0 > 0 Or IsNull(df0) Or IsEmpty(df0)) And f > 0

    Columns("E:H").HorizontalAlignment = xlCenter    

Worksheets(1).Name = "ImportActiviteMedecins"

Cells(1, 1).Activate

ActiveWorkbook.Save

'    Enregistrement après regroupement des pages sur une seule sous le nom "ImportActiviteMedecins"

End Sub"  

SendKeys ("{LEFT}{ENTER}")   

SelectPave

Sub SelectPave()
    l1 = ActiveCell.Row
    C1 = ActiveCell.Column  
    Cells(l1, C1).End(xlToRight).Select
    c2 = ActiveCell.Column
    Cells(l1, C1).End(xlDown).Select
    l2 = ActiveCell.Row    
    Range(Cells(l1, C1), Cells(l2, c2)).Select
End Sub

Sub StatAgendaRegrouptCahier_vjpp()
Df = ActiveWorkbook.Sheets.Count
DM = Worksheets(Df).Name ' Nom de la dernière feuille ..!!!!! mafeuilee201311
Mois = Right(DM, 2)
An = Left(Right(DM, 7), 4)
DM = Right(DM, 7)
delireca = 2
' *** sur mon poste
' *** ActiveWorkbook.SaveAs Filename:="C:\Users\PJP\Desktop\RecapStatCs" & An & "-" & Mois & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.SaveAs Filename:= _
"D:\D-Mes documents\Cs4_GENERALES\Docts" & An & "\StatsCs\RecapStatCs" & An & "-" & Mois & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
' Insérer feuille récapitulative
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "ImportActiviteMedecins"
Set shrecap = ActiveSheet
shrecap.Range("A1:I1") = Array("titre 1", "titre 2", "titre 3", "titre 4", "titre 5", "titre 6", "titre 7", "titre 8", "titre 9")
' boucle réspérer données des feuilles
For Each sh In Worksheets
    If sh.Name <> "ImportActiviteMedecins" Then
       sh.Activate
        'Do
        'Worksheets(f).Activate
    '    NF = Worksheets(f).Name ' NF = Nom feuille courante, Index (f)
        NF = sh.Name
        If Left(NF, 3) = Mid(Cells(2, 2), 8, 3) And Not (IsNull(NFN) Or IsEmpty(NFN)) Then
            ' si 3_1er caractères du nom de la feuille courante = n°UH de cellule UH
            'sh.Cells(2, 1).Select
            If IsEmpty(Cells(3, 1)) Then
                Range(Cells(2, 1), Cells(2, 9)).Copy Destination:=shrecap.Cells(delireca, 1)
            Else
                l2 = Cells(Rows.Count, 1).End(xlUp).Row
                c2 = Cells(2, Columns.Count).End(xlToLeft).Column
                Range(Cells(2, 1), Cells(l2, c2)).Copy Destination:=shrecap.Cells(delireca, 1)
            End If
        Else
            NFN = Left(Cells(2, 2), 4) & "#" & Mid(Cells(2, 2), 8, 3) & "#" & Mid(Cells(2, 2), 14, 25) & "#" & An
            NFN = IIf(Len(NFN) < 32, NFN, Left(NFN, 26) & Right(NFN, 5))
            l2 = sh.Cells(Rows.Count, 1).End(xlUp).Row
            c2 = sh.Cells(2, Columns.Count).End(xlToLeft).Column
            Range(Cells(2, 1), Cells(l2, c2)).Copy Destination:=shrecap.Cells(delireca, 1)
         End If
         delireca = shrecap.Cells(Rows.Count, 1).End(xlUp).Row + 1
    End If
Next sh

For Each sh In Worksheets
    Application.DisplayAlerts = False
    If sh.Name <> "ImportActiviteMedecins" Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
Columns("E:H").HorizontalAlignment = xlCenter
ActiveWorkbook.Save
' Enregistrement après regroupement des pages sur une seule sous le nom "ImportActiviteMedecins"
End Sub