VBA code aanpassen

Status
Niet open voor verdere reacties.
R

Roma

Gebruiker
Lid geworden
7 sep 2013
Berichten
515
beste,

Ik heb van Warme bakkertje (Rudi) een fantastische code gekregen om e-mails te versturen.
Deze code werkt perfect als ik alle e-mail adressen invoer.
Nu is mijn vraag of het mogelijk is om enkele adressen over te slaan.
Bijv. verstuur collega 1 en colega 3 en collega 30
 

Bijlagen

  • E-mail kaart.xlsm
    43,7 KB · Weergaven: 38
Dat gebeurd nu toch?
Enkel je bezit niet alle tabbladen, maar ik neem aan dat die er voor nu even uit zijn gehaald.
 
Harry,
klopt ik heb niet alle tabbladen toegevoegd.
Als ik collega 1 en collega 3 selecteer dan krijg ik de foutmelding " kan een of meer namen niet herkennen". Dit kan alleen opgelost worden als er van iedereen een e-mail adres ingevoerd. Daarom de vraag of dat te omzeilen is.
 
Maak eerst de code eens netjes op want nu is amper te lezen wat bij elkaar hoort en ik kan me niet voorstellen dat Rudi dat zo heeft geleverd.
 
Dat geloof ik, maar niet dat het zo was opgemaakt. Is geen kritiek maar een advies. Zorg ervoor met de juiste inspringpunten dat een End IF onder de bijbehorende If staat zodat je kunt zien dat die bij elkaar horen. Hetzelfde geldt voor With...End With, For...Next, Select...End Select enzovoort. Dat maakt code een heel stuk leesbaarder en ook aantrekkelijker voor anderen om zich eens in je probleem te verdiepen. Iemand die best wel wil helpen maar nu de structuur ziet zal direct denken van laat maar.
 
De code:

Code: 
Sub OPTPDF()
'Code gekregen van Helpmij (Rudi)
   sn = Sheets("Vakkaart").Range("B10").CurrentRegion
    For d = 2 To UBound(sn)
        If sn(d, 1) = "E-mail" Then tomail = tomail & sn(d, 2) & ";"
           Next
           
    For i = 1 To 1
    Application.ScreenUpdating = False
    'Range V2 staan de namen van de collega's
    'Range B3 staan de e-mail adressen
    
                 If InStr(1, tomail, Sheets("K" & i).Range("V2").Value, vbTextCompare) Then
            With Sheets("K" & i)
                Fname = .Range("V2").Value & ".pdf"
                eAddress = .Range("B3").Value
                .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & Fname
                 End With
                 
            With CreateObject("Outlook.application").CreateItem(0)
                .To = eAddress
                .Subject = " maand"
                .Body = "Bijgaand: " _
                        & vbNewLine & "" _
                        & vbNewLine & ""
                .Attachments.Add ThisWorkbook.Path & "\" & Fname
                .Send
                End With
                
                Kill ThisWorkbook.Path & "\" & Fname
                Application.ScreenUpdating = True
               End If
              Next
      End Sub
 
Nee. Kijk eens naar dit:
Code: 
Sub OPTPDF()
'Code gekregen van Helpmij (Rudi)
   sn = Sheets("Vakkaart").Range("B10").CurrentRegion
    For d = 2 To UBound(sn)
        If sn(d, 1) = "E-mail" Then tomail = tomail & sn(d, 2) & ";"
    Next
           
    For i = 1 To 1
    	Application.ScreenUpdating = False
    	'Range V2 staan de namen van de collega's
    	'Range B3 staan de e-mail adressen
    
        If InStr(1, tomail, Sheets("K" & i).Range("V2").Value, vbTextCompare) Then
            With Sheets("K" & i)
                Fname = .Range("V2").Value & ".pdf"
                eAddress = .Range("B3").Value
                .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & Fname
            End With
                 
            With CreateObject("Outlook.application").CreateItem(0)
                .To = eAddress
                .Subject = " maand"
                .Body = "Bijgaand: " _
                        & vbNewLine & "" _
                        & vbNewLine & ""
                .Attachments.Add ThisWorkbook.Path & "\" & Fname
                .Send
            End With
                
            Kill ThisWorkbook.Path & "\" & Fname
            Application.ScreenUpdating = True
        End If
    Next
End Sub
 
Test dit stukje eens.
Code: 
With CreateObject("Outlook.application").CreateItem(0)
                .To = eAddress
                .Subject = " maand"
                .Body = "Bijgaand: " _
                        & vbNewLine & "" _
                        & vbNewLine & ""
                .Attachments.Add ThisWorkbook.Path & "\" & Fname
      On Error Resume Next
                .Send
           If Err.Number <> 0 Then
                    MsgBox "Verander zo nodig mailadres"
                .display
              On Error GoTo 0
         End If
 End With
 
Harry,
Bedankt voor je reactie. Helaas er gebeurt niets. er komt ook geen waarschuwing van de msgbox.
 
In mijn test heb ik mailadres D9 verwijderd.
 
beste Harry,
Ik heb het getest. en het werkt. Maar nu(in mijn voorbeeld) moet ik nogmaals het e-mailadres invoeren.
 

Bijlagen

  • E-mail kaart.xlsm
    80,1 KB · Weergaven: 18
Zonder Harry tekort te willen doen heb ik nog even gekeken of ik mee kon helpen maar de code is qua inspringpunten nog net zoals in het begin en niet zoals ik adviseerde in #8. Ik heb daarom het document maar weer gesloten.
 
Ik ben niet echt content met de code daar collega9 in tabblad K2 staat.
Test het maar eens, anders moet de gehele code maar op de schop.
Code: 
Sub OPTPDF()
'Code gekregen van Helpmij (Rudi)
Application.ScreenUpdating = False
   sn = Sheets("Vakkaart").Range("B10").CurrentRegion
    For d = 2 To UBound(sn)
        If sn(d, 1) = "E-mail" Then tomail = tomail & sn(d, 2) & ";"
           Next
For i = 1 To 9
    'Range V2 staan de namen van de collega's
    'Range B3 staan de e-mail adressen
    
 If InStr(1, tomail, Sheets("K" & i).Range("V2").Value, vbTextCompare) > 0 Then
            With Sheets("K" & i)
               If Not IsEmpty(.Range("B3")) Then
                  Fname = .Range("V2").Value & ".pdf"
                  eAddress = .Range("B3").Value
                  .ExportAsFixedFormat 0, ThisWorkbook.Path & "\" & Fname
               End If
            End With
        If Fname <> vbNullString Then
          With CreateObject("Outlook.application").CreateItem(0)
                        .To = eAddress
                        .Subject = " maand"
                        .Body = "Bijgaand: " _
                                & vbNewLine & "" _
                                & vbNewLine & ""
                        .Attachments.Add ThisWorkbook.Path & "\" & Fname
              On Error Resume Next
                        .Send
                   If Err.Number <> 0 Then
                            MsgBox "Verander zo nodig mailadres"
                        .display
                      On Error GoTo 0
                   End If
          End With
         Kill ThisWorkbook.Path & "\" & Fname
        End If
     Application.ScreenUpdating = True
  End If
 Next
End Sub
 
Harry,
Allereerst bedankt voor het meedenken.
Waar nu geen e-mailadressen staan krijg ik lege mails binnen van Collega 1

Ik denk inderdaad dat ik wat anders moet gaan verzinnen.
Nogmaals bedankt voor je inzet
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan