Vérification de macro 2

Suite à mon précédent poste, je me suis mis a retravailler une de mes plus grosse macro. (Encore merci Galopin01 pour ton aide, tu m'as beaucoup apris)

La macro retravaillé fonctionne, mais je voulais juste m'assurer que ce que je m'éloigne de ce "codage flou" et savoir quelles sont les amélioration que je peux encore y apporter.

Toujours avide d'apprendre plus comment codé mes macros

Voici l'ancienne :

Sub Generer_Rapport_PDJ()
    On Error GoTo ErrorHandler ' Gestion des erreurs

        'boite de msg avec question oui ou non, Si réponse non, arrete la macro
        If MsgBox("Est-ce que les BF11 sont rentrés ?", vbYesNo, "Demande de confirmation") = vbNo Then
            Exit Sub
        End If

    ' Activer la feuille "PDJ inclus"
    Sheets("PDJ inclus").Activate

    ' Définir la variable de ligne et trouver la dernière ligne non vide de la colonne J
    Dim ligne As Long
    ligne = Evaluate("MAX(IF(J:J<>"""",ROW(J:J),0))")

    ' Copier la plage de données de A10 à L10 jusqu'à la dernière ligne non vide
    Sheets("PDJ inclus").Range("A10:L10").Resize(ligne - 9).Copy

    ' Activer la feuille "Impression Liste PDJ"
    Sheets("Impression Liste PDJ").Activate

    ' Ouvrir le classeur cible
    Dim targetWorkbook As Workbook
                                                ' chemin réseau                         ' nom fichier
    Set targetWorkbook = Workbooks.Open(Filename:="\\NTSERVER1\office\Pointage PDJ Amelys\Pointage PDJ Vide COPIER avant d'utiliser.xlsm")

    ' Coller les valeurs copiées dans la feuille "Copie Liste PDJ"
    With targetWorkbook.Worksheets("Copie Liste PDJ").Range("A10")
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With

    ' insertion du contenu de la macro "Trier" pour remplacer Application.Run
    Dim ws As Worksheet
    Set ws = targetWorkbook.Worksheets("Pointage")

    ws.Activate

    Dim sortRanges As Variant
    sortRanges = Array("B2:B221", "F2:F221", "J2:J221", "N2:N221", "R2:R221", "V2:V221")

    Dim i As Integer
    For i = LBound(sortRanges) To UBound(sortRanges)
        ws.Sort.SortFields.Clear
        ws.Sort.SortFields.Add2 Key:=ws.Range(sortRanges(i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ws.Sort
            .SetRange ws.Range(sortRanges(i))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next i

    ws.Range("A2").Select

    ' Définir les variables de date pour nommer le fichier
    Dim laDate As Date, leMois As String, leJour As String, leNom As String, MoisFichier As String
    laDate = Date
    leMois = Format(laDate, "MM")
    leJour = Format(laDate, "dd")
    MoisFichier = Format(laDate, "M MMMM")
    leNom = "Pointage PDJ " & leJour & "-" & leMois

    ' Afficher le nom du fichier dans une boîte de dialogue
    MsgBox leNom

    ' Définir le répertoire de sauvegarde
    Dim vdir As String
    vdir = "\\NTSERVER1\office\Pointage PDJ Amelys\" + MoisFichier + "\" ' chemin réseau

    ' Désactiver les alertes de sauvegarde
    Application.DisplayAlerts = False

    ' Sauvegarder le classeur cible sous le nouveau nom
    targetWorkbook.SaveAs Filename:=vdir & leNom

    ' Fermer le classeur cible et réactiver les alertes
    targetWorkbook.Close SaveChanges:=True
    Application.DisplayAlerts = True

    'parie d'impression des rapport PDJ
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig As Long, DerCol As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set f1 = Sheets("liste pdj")
    Set f2 = Sheets("Impression Liste PDJ")
    DerLig = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol = f1.Cells(1, Columns.Count).End(xlToLeft).Column
    f2.Select
    Cells.Clear
    Range(f1.Cells(1, "A"), f1.Cells(DerLig, DerCol)).Copy f2.Range("A1")
    Range(f2.Cells(1, "A"), f2.Cells(DerLig, DerCol)).Value = Range(f2.Cells(1, "A"), f2.Cells(DerLig, DerCol)).Value
    For i = 5 To DerCol - 3 Step 4
        With f2.Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(Cells(1, i), Cells(DerLig, i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range(Cells(1, i), Cells(DerLig, i + 2))
            .Header = xlNo
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next i
    Range("A:A,E:E,I:I,M:M,Q:Q,U:U,Y:Y,AC:AC,AD:AD").Select
    Range("AD1").Activate
    Selection.NumberFormat = "General"
    Range("A1").Select
    Sheets("PDJ inclus").Select
    ligne = Evaluate("max(if(J:J<>"""",row(J:J),0))")
    If ligne >= 9 Then
        Range("A1:J1").Resize(ligne).Select
    End If
    Selection.PrintOut Copies:=2, Collate:=True
    Sheets("Minibars").Select
    ligne = Evaluate("max(if(G:G<>"""",row(G:G),0))")
    If ligne >= 9 Then
        Range("A1:G1").Resize(ligne).Select
    End If
    Selection.PrintOut Copies:=2, Collate:=True

    Sheets("Daily").Select

    'definie le nom du Daily night
    Dim laDate2 As Date, leMois2 As String, leJour2 As String, Daily As String
    laDate2 = Date - 1
    leMois2 = Format(laDate2, "MM")
    leJour2 = Format(laDate2, "dd")
    Daily = "TEST Daily " & leJour2 & "-" & leMois2

    'copie les info du classeur 209 pour les coller dans sheet daily report du daily night
    '1er partie
    Range("B5:B13").Select
    Selection.Copy
    Windows(Daily).Activate
    Sheets("Daily Report").Select
    Range("E5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    '2e partie
    Windows("TEST Classeur 209# avec macro").Activate
    Range("E5:E13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(Daily).Activate
    Sheets("Daily Report").Select
    Range("H5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'copie le RateV du classeur 209 pour les coller dans sheet donnée du daily night
    Windows("TEST Classeur 209# avec macro").Activate
    Sheets("Chambres <295 €").Select
    Range("D3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows(Daily).Activate
    Sheets("Données").Select
    Range("C138").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    'Copier TO, PM et Revpar pour control
    ' Définir les objets Workbook et Worksheet
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Set wbSource = ThisWorkbook
    Set wbDestination = Workbooks(Daily)

    ' Copier et coller les valeurs de la feuille source vers la feuille destination
    With wbSource.Sheets("Chambres <295 €")
        wbDestination.Sheets("Données").Range("I141:J141").Value = .Range("K3").Value
        wbDestination.Sheets("Données").Range("K141:L141").Value = .Range("L3").Value
        wbDestination.Sheets("Données").Range("M141:N141").Value = .Range("M3").Value
    End With

    'Tri des #RC <295€
    ActiveSheet.Range("$B$1:$B$900").AutoFilter Field:=1, Criteria1:="<>0"

    'Copier les données sur le Fichier Occupe
    Dim WbC As Workbook
    Dim WsS As Worksheet
    Dim WsC As Worksheet
    Dim iR&
    Set WsS = Feuil23 'Feuille "Source
    'Ouvrir le classeur Civble (Occup)
    ' chemin réseau    ' nom fichier
    Set WbC = Workbooks.Open(Filename:="O:\NIGHTS\Occup" & Year(Date) & ".xls")
    Set WsC = WbC.Worksheets(Format(Date, "MMMM")) 'Feuillle Cible
        With WsC
        'Definir la ligne en fonction de la date
        iR = Day(Date) + 1
        'copier les données du 209 et coler au bon endroi sur Occup
            .Range("B" & iR) = WsS.Range("E3")
            .Range("G" & iR) = WsS.Range("F3")
            .Range("K" & iR) = WsS.Range("H3")
        WbC.Save
        End With

    ' Sortie propre de la subroutine
    Exit Sub

ErrorHandler:
    ' Gérer les erreurs
    MsgBox "Une erreur s'est produite : " & Err.Description
    Application.DisplayAlerts = True

End Sub

Function MacroExists(wb As Workbook, macroName As String) As Boolean
    Dim vbComp As Object
    Dim vbModule As Object
    Dim line As String
    Dim found As Boolean

    found = False

    For Each vbComp In wb.VBProject.VBComponents
        Set vbModule = vbComp.CodeModule
        For i = 1 To vbModule.CountOfLines
            line = vbModule.Lines(i, 1)
            If InStr(1, line, "Sub " & macroName, vbTextCompare) > 0 Then
                found = True
                Exit For
            End If
        Next i
        If found Then
            Exit For
        End If
    Next vbComp

    MacroExists = found
End Function

Et la macro retravaillé :

Sub TEST_Generer_Rapport_PDJ()
    On Error GoTo ErrorHandler ' Gestion des erreurs

    ' Confirmation de l'entrée des BF11
    If MsgBox("Est-ce que les BF11 sont rentrés ?", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub

    ' Variables
    Dim ligne As Long
    Dim laDate As Date
    Dim leMois As String, leJour As String, leNom As String, MoisFichier As String
    Dim vdir As String
    Dim ws As Worksheet
    Dim targetWorkbook As Workbook
    Dim wbSource As Workbook
    Dim wbDestination As Workbook
    Dim iR As Long
    Dim sortRanges As Variant

    ' Activer la feuille "PDJ inclus" et trouver la dernière ligne non vide de la colonne J
    With Sheets("PDJ inclus")
        .Activate
        ligne = Evaluate("MAX(IF(J:J<>"""",ROW(J:J),0))")
        .Range("A10:L10").Resize(ligne - 9).Copy
    End With

    ' Ouvrir le classeur cible et coller les données
    Set targetWorkbook = Workbooks.Open(Filename:="\\NTSERVER1\office\Pointage PDJ Amelys\Pointage PDJ Vide COPIER avant d'utiliser.xlsm")
    With targetWorkbook.Worksheets("Copie Liste PDJ")
        .Range("A10").PasteSpecial Paste:=xlPasteValues
    End With

    ' Trier les données
    Set ws = targetWorkbook.Worksheets("Pointage")
    ws.Activate
    sortRanges = Array("B2:B221", "F2:F221", "J2:J221", "N2:N221", "R2:R221", "V2:V221")
    For i = LBound(sortRanges) To UBound(sortRanges)
        With ws.Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=ws.Range(sortRanges(i)), SortOn:=xlSortOnValues, Order:=xlAscending
            .SetRange ws.Range(sortRanges(i))
            .Header = xlNo
            .Apply
        End With
    Next i

    ' Nommer et sauvegarder le fichier
    laDate = Date
    leMois = Format(laDate, "MM")
    leJour = Format(laDate, "dd")
    MoisFichier = Format(laDate, "M MMMM")
    leNom = "Pointage PDJ " & leJour & "-" & leMois
    vdir = "\\NTSERVER1\office\Pointage PDJ Amelys\" & MoisFichier & "\"
    Application.DisplayAlerts = False
    targetWorkbook.SaveAs Filename:=vdir & leNom
    targetWorkbook.Close SaveChanges:=True
    Application.DisplayAlerts = True

    ' Impression des rapports PDJ
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig As Long, DerCol As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set f1 = Sheets("liste pdj")
    Set f2 = Sheets("Impression Liste PDJ")
    DerLig = f1.Range("A" & Rows.Count).End(xlUp).Row
    DerCol = f1.Cells(1, Columns.Count).End(xlToLeft).Column
    f2.Select
    Cells.Clear
    Range(f1.Cells(1, "A"), f1.Cells(DerLig, DerCol)).Copy f2.Range("A1")
    Range(f2.Cells(1, "A"), f2.Cells(DerLig, DerCol)).Value = Range(f2.Cells(1, "A"), f2.Cells(DerLig, DerCol)).Value
    For i = 5 To DerCol - 3 Step 4
        With f2.Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Range(Cells(1, i), Cells(DerLig, i)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Range(Cells(1, i), Cells(DerLig, i + 2))
            .Header = xlNo
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next i
    Range("A:A,E:E,I:I,M:M,Q:Q,U:U,Y:Y,AC:AC,AD:AD").Select
    Range("AD1").Activate
    Selection.NumberFormat = "General"
    Range("A1").Select

    ' Impression des feuilles
    Sheets("PDJ inclus").Select
    ligne = Evaluate("max(if(J:J<>"""",row(J:J),0))")
    If ligne >= 9 Then
        Range("A1:J1").Resize(ligne).Select
    End If
    Selection.PrintOut Copies:=2, Collate:=True
    Sheets("Minibars").Select
    ligne = Evaluate("max(if(G:G<>"""",row(G:G),0))")
    If ligne >= 9 Then
        Range("A1:G1").Resize(ligne).Select
    End If
    Selection.PrintOut Copies:=2, Collate:=True

    ' Copier les informations du classeur 209 dans Données et Daily Report
    Set wbSource = Workbooks("TEST Classeur 209# avec macro")
    Set wbDestination = Workbooks("TEST Daily " & Format(Date - 1, "dd-MM"))

    With wbSource.Sheets("Daily")
        wbDestination.Sheets("Daily Report").Range("E5:E13").Value = .Range("B5:B13").Value
        wbDestination.Sheets("Daily Report").Range("H5:H13").Value = .Range("E5:E13").Value
        wbDestination.Sheets("Daily Report").Range("L5:L13").Value = .Range("G5:G13").Value
    End With

    With wbSource.Sheets("Chambres <295 €")
        .AutoFilterMode = False ' Désactiver les filtres existants
        .Range("$B$1:$B$900").AutoFilter Field:=1, Criteria1:="<>0"
        wbDestination.Sheets("Données").Range("C138").Value = .Range("D3").Value
        wbDestination.Sheets("Données").Range("C141").Value = .Range("U3").Value
        wbDestination.Sheets("Données").Range("C8:C11").Value = .Range("W1:W4").Value
        wbDestination.Sheets("Données").Range("I141:J141").Value = .Range("K3").Value
        wbDestination.Sheets("Données").Range("K141:L141").Value = .Range("L3").Value
        wbDestination.Sheets("Données").Range("M141:N141").Value = .Range("M3").Value
        .Activate
    End With

    ' Copier les données sur le fichier Occup
    Set WsS = Feuil23 ' Feuille source
    Set WbC = Workbooks.Open(Filename:="O:\NIGHTS\Occup" & Year(Date) & ".xls")
    Set WsC = WbC.Worksheets(Format(Date, "MMMM"))

    iR = Day(Date) + 1
    With WsC
        .Range("B" & iR).Value = WsS.Range("E3").Value
        .Range("G" & iR).Value = WsS.Range("F3").Value
        .Range("K" & iR).Value = WsS.Range("H3").Value
        WbC.Save
    End With

    ' Sortie propre de la subroutine
    Exit Sub

ErrorHandler:
    MsgBox "Une erreur s'est produite : " & Err.Description
    Application.DisplayAlerts = True
End Sub

Merci

Bonjour,

Je vois que Galopin vous a donné de bons conseils.

Je n'ai rien à redire sur quasiment l'ensemble de votre macro retravaillée. Il n'y a qu'une partie, selon moi, qui est passée à la trappe. Je vous met ci-après le code revu et commenté. Dans le code envoyé c'est la partie ligne 106 et +.

    ' inutile car .Activate change la selection
    ' Range("A:A,E:E,I:I,M:M,Q:Q,U:U,Y:Y,AC:AC,AD:AD").Select

    ' comme précédemment, Activate/Select inutile ici, utilisez directement l'objet
    Range("AD1").NumberFormat = "General"

    ' ?
    ' Range("A1").Select

    ' Impression des feuilles
    ' il est préférable de .Activate les feuilles, cela évite d'en selection 2 à la fois ce qui est possible avec .Select
    ' bon on pourrait faire sans mais pour ne pas casser votre code c'est acceptable ici
    Sheets("PDJ inclus").Activate
    ligne = Evaluate("max(if(J:J<>"""",row(J:J),0))")
    If ligne >= 9 Then
        Range("A1:J1").Resize(ligne).PrintOut Copies:=2, Collate:=True
    End If
    ' je ne pense pas que vous voulez imprimer si la ligne est infèrieure à 9 ? sinon qu'imprimez-vous ? la dernière seletion = feuille entière
    'Selection.PrintOut Copies:=2, Collate:=True

    Sheets("Minibars").Activate
    ligne = Evaluate("max(if(G:G<>"""",row(G:G),0))")
    If ligne >= 9 Then
        Range("A1:G1").Resize(ligne).PrintOut Copies:=2, Collate:=True
    End If
    ' cf. precedent
    ' Selection.PrintOut Copies:=2, Collate:=True

Merci pour m'avoir signalé le petit raté.

Pour la 1ere ligne, j'ai changé par :

Range("A:A,E:E,I:I,M:M,Q:Q,U:U,Y:Y,AC:AC,AD:AD").NumberFormat = "General"

En effet, les .select étaient inutile, car se sont ses colonnes où je doit changer le format.

J'ai changé les autre .Select en .activate et je retient pour l'avenir

Les 9 premières lignes sont de la mise en page pour les impressions, le contenue changeant (crée par des formule) commence à partir de la ligne 10. S'il n'y a pas de contenu (ce qui ne devrait pas arriver théoriquement), je ne veux pas imprimer.

Le but étant d'imprimer que la sélection qui est défini par là ou il y a du contenu.

Merci pour ton aide