XL 2016 Correction Code VBA de débutant

AntoineLTO

XLDnaute Nouveau
Bonjour à toutes et tous,

J'éprouve des difficultés à perfectionner le code que je vais inscrire plus loin. C'est la première fois que je touche à de la macro.

Mon but avec ce code est d'envoyer une relance d'un impayé par mail. Là où le bat blesse, c'est d'une part: en objet je n'arrive pas à faire apparaître le nom du client après "konto" (Colonne A ou 1) et ensuite le numéro du client (colonne G ou 7)

Ensuite je ne sais pas comment ajouter une portion de code qui permettrait l'envoi d'un mail pour plusieurs factures d'un même client, et qui ajouterait les références factures les unes à la suite des autres (plutôt qu'un mail par facture) à condition bien sûr qu'elles aient dépassé la date d'échéance +3 jours. Exemple comme suit:
upload_2019-2-14_9-33-14.png




Ainsi les clients dont les relances ont déjà été envoyées ne sont pas concernés, la cliente Stéphanie recevrait un mail mais avec trois références de facture (45887, 23896, 55694), le client Jean recevrait un mail avec une référence (740012).

Aujourd'hui avec ce code et après plusieurs tests, ni le numéro de client ni leur nom n’apparaît en objet, si un client a plusieurs factures il reçoit un mail avec trois fois le corps du mail d’affilée avec simplement la référence qui change.

Voici le code que j'utilise:

VB:
Sub Email()

Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim VAdresse As String
Dim VObjet As String
Dim VMessage As String
Dim VCellule As Object
Dim Lig As Long
Dim DateRef

DateRef = DateAdd("d", 3, Date)  ' date du jour +3jours

Lig = 2
Do While Cells(Lig, 1).Value <> ""
  If Cells(Lig, 6).Value = "" Then
       VMessage = ""
       ClientEnCours = Cells(Lig, 1).Value
       VAdresse = Cells(Lig, 5).Value 
       While ClientEnCours = Cells(Lig, 1).Value  
         If Cells(Lig, 2).Value < DateRef Then    
            Cells(Lig, 6).Value = "Envoyé"
            VMessage = VMessage & "Bei der oben aufgeführten Rechnung konnten wir leider noch keinen Zahlungseingang feststellen. Sicherlich handelt es sich nur um ein Versehen. Wir haben dem Schreiben eine Kopie der Rechnung  " & Cells(Lig, 4).Value _
                & " beigefügt." & vbCrLf _
                & "Wir möchten Sie bitten, den Rechnungsbetrag zu überweisen, anbei erhalten Sie dafür unsere Bankverbindung. " & vbCrLf & vbCrLf _
                & "Falls es Gründe geben sollte, die einer Zahlung entgegen stehen, bitten wir Sie, uns diese mitzuteilen. " & vbCrLf & vbCrLf _
                & "Falls Sie zwischenzeitlich die Zahlung veranlasst haben, bitten wir Sie, dieses Schreiben als gegenstandslos zu betrachten." & vbCrLf & vbCrLf _
                & "Kontoinhaber : Luneau Technology Deutschland GmbH " & vbCrLf _
                & "Bank code : 37010600 " & vbCrLf _
                & "IBAN : DE17 3701 0600 1087 8411 52 " & vbCrLf _
                & "SWIFT/BIC : BNPADEFXXX " & vbCrLf

          End If
          Lig = Lig + 1
       Wend
       If VMessage <> "" Then 
          VMessage = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & VMessage
          VMessage = VMessage & vbCrLf & "Cordialement, Best regards, Mit freundlichen Grüßen, Atentamente,Saluti." & vbCrLf & vbCrLf _
          & "Debitorenbuchlaltung "
          VObjet = "Konto - " & Cells(Lig, 1).Value _
                & Cells(Lig, 7).Value  'description

          Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
          Set outlookMessage = outlookDossier.Items.Add
          With outlookMessage
           .Subject = VObjet
           .Recipients.Add VAdresse
           .Body = VMessage
           .OriginatorDeliveryReportRequested = False
           .ReadReceiptRequested = False
           .Send
          End With
        End If
  
   Else
       Lig = Lig + 1
   End If
Loop

Set outlookMessage = Nothing
Set outlookDossier = Nothing

End Sub

Je précise que j'ai pris ce code sur internet et l'ai modifié par la suite, je n'ai commencé le code qu'hier et toute remarque que vous feriez devra être très précise pour que mon petit cerveau la comprenne ;).


Je vous remercie pour le temps que vous m'accorderez.

Cordialement,
 

Pièces jointes

  • upload_2019-2-14_9-25-16.png
    upload_2019-2-14_9-25-16.png
    57.3 KB · Affichages: 30

Discussions similaires

Réponses
5
Affichages
166

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
312 086
Messages
2 085 197
Membres
102 814
dernier inscrit
JLGalley