Microsoft 365 Boucle Do until

[danpom302]

Bonjour, j'ai un code VBA qui ne fonctionne pas. Erreur de compilation : Boucle sans Do, alors que Do est dans le code.

Pouvez-vous m'aider s.v.p. ? Dan

Sub E_Impression_Multiple_Imprimer_Envoi_De_Courriel()
'
' Sélectionner la feuille Impression multiple et la déprotéger
    Sheets("Impression multiple").Select
    ActiveSheet.Unprotect "lune666"
        
    Dim MonFichier As String
    Dim MonAdresse As String
    Dim mon_pdf As String
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    Dim control_app
    Set control_app = GetObject(, "Outlook.Application")
    
' Ne pas raffraichir l'écran
    Application.ScreenUpdating = False
    
Do While Range("O3").Value > ""

        mon_pdf = Range("N2").Value
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\" & mon_pdf & " .pdf", Quality:=xlQualityStandard
        MonFichier = ActiveWorkbook.Path & "\" & mon_pdf & " .pdf"
        MonAdresse = Range("AL1").Text

' 1) Si AB1 égale rien, Imprimer le contrat
        If Range("AB1").Value > "" Then
      
' 2) Imprimer le contrat de la feuille Impression Multiple
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
        Range("A1").Select
    
Else
' 3) S'il y a une adresse de courriel Range("AB1"), envoyer le contrat par courriel
    With OutMail
        .To = Range("AB1").Value ' Client
        .CC = Range("AL1").Value ' Déneigeur
        .BCC = Range("AM1").Value ' Moi
        .Subject = Range("N2").Value
        .HTMLBody = "<p>Bonjour,</p>" & "<p>Ci-joint, votre contrat de déneigement pour la saison en cour. " & "<br>" & "<p>Cordialement, " & "<br>" & "<p>" & "Kevin Trottier"
        .Attachments.Add MonFichier
        .Send
        
' Ne pas raffraichir l'écran
    Application.ScreenUpdating = False
        
' Sélectionner le prochain contrat à imprimer ou à envoyer par courriel
    Range("O3:AI3").Select
    Selection.Copy
    Range("O1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("O3:AI3").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("O1").Select

Loop
    
' Sélectionner la cellule C8
    Range("C8").Select

' Enregistrer le classeur actif
    ActiveWorkbook.Save
    
End If
End Sub

 

[Hasco]

Re bonjour,

J'avais mentionné ce manque de End With (en autre chose) dès le post #4 il faut lire les réponses...

Cordialement

 

[danpom302]

Très bien Phil69970. Bonne journée et merci encore. Dan