Microsoft 365 Boucle Do until

danpom302

XLDnaute Nouveau
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

VB:
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
 
Solution
Bonjour @danpom302

Ton code est un peu bizarre....

VB:
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
   
' Exécuter ce qui suit en boucle.
Do While Range("O3") = ""
   
    If Range("AB1") = "" Then
       
    Else
' 1) Copier les données de la plage O3:AI3...

Statistiques des forums

Discussions
292 868
Messages
1 926 871
Membres
183 293
dernier inscrit
GMS