• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

E-mail met bijlage versturen vanuit Excel

Status
Niet open voor verdere reacties.

Purrel

Gebruiker
Lid geworden
3 jan 2008
Berichten
28
Beste mensen,

Gedurende mijn werkzaamheden komt het nogal eens voor dat ik een exceloverzicht moet gaan opknippen en naar veel verschillende collega’s moet sturen. Nu had ik me bedacht dat het sneller moest kunnen met behulp van een macro. En inderdaad, ik heb de onderstaande macro gevonden op deze zeer handige site: http://www.rondebruin.nl/tips.htm

Code:
Sub Send_Row_Or_Rows_Attachment_2()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim NewWB As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long

    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Set filter sheet, you can also use Sheets("MySheet")
    Set Ash = Sheets("Te verzenden")

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                'Filter the FilterRange on the FieldNum column
                FilterRange.AutoFilter Field:=FieldNum, _
                                       Criteria1:=Cws.Cells(Rnum, 1).Value

                'Copy the visible data in a new workbook
                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With

                Set NewWB = Workbooks.Add(xlWBATWorksheet)

                rng.Copy
                With NewWB.Sheets(1)
                    .Cells(1).PasteSpecial Paste:=8
                    .Cells(1).PasteSpecial Paste:=xlPasteValues
                    .Cells(1).PasteSpecial Paste:=xlPasteFormats
                    .Cells(1).Select
                    Application.CutCopyMode = False
                End With

                'Create a file name
                TempFilePath = Environ$("temp") & "\"
                TempFileName = "Testbestand " & Format(Now, "yyyy-mm-dd")
                FileExtStr = ".xls": FileFormatNum = -4143

                'Save, Mail, Close and Delete the file
                Set OutMail = OutApp.CreateItem(0)

                With NewWB
                    .SaveAs TempFilePath & TempFileName _
                          & FileExtStr, FileFormat:=FileFormatNum
                    On Error Resume Next
                    With OutMail
                        .to = Cws.Cells(Rnum, 1).Value
                        .CC = "frank@email.nl"
                        .Subject = "Testbestand"
                        .Attachments.Add NewWB.FullName
                        .Body = "Beste," & vbNewLine & _
                                " " & vbNewLine & _
                                "bij deze het overzicht." & vbNewLine & _
                                "Veel succes ermee!" & vbNewLine & _
                                " " & vbNewLine & _
                                "Met vriendelijke groet," & vbNewLine & _
                                " " & vbNewLine & _
                                "Frank" & vbNewLine
                        .Display  'Or use Send
                    End With
                    On Error GoTo 0
                    .Close savechanges:=False
                End With

                Set OutMail = Nothing
                Kill TempFilePath & TempFileName & FileExtStr
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False

        Next Rnum
    End If

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Op zich werkt het perfect. Per emailadres worden keurig de bijbehorende regels in een nieuw aangemaakt exceloverzicht verstuurd. Zie het onderstaande voorbeeld. Helaas voldoet dat niet helemaal aan mijn wensen.

voorbeeld1.jpg


Ik zou graag zien dat de regels niet per emailadres worden gefilterd, maar op naam. Dat betekent in het onderstaande voorbeeld dat ‘Carla’ twee emails ontvangt. Eentje met een Exceloverzicht met de regels van ‘KKK’ en de andere met de regels van ‘MMM’. Zoals hieronder.

voorbeeld2.jpg


Hoewel ik de werking van de macro wel aardig begrijp, is het aanpassen ervan naar een nieuwe situatie momenteel nog een brug te ver. Is er iemand die me kan vertellen of het überhaupt mogelijk is wat ik wil? En zo ja, hoe? Alvast bedankt voor jullie moeite!

Bekijk bijlage Voorbeeld.zip
 
Zonder verder iets getest of bekeken te hebben lijkt het me voldoende om in de regel CopyToRange:=Cws.Range("A1") de A1 in D1 te wijzigen.
 
Dat heb ik zojuist getest, maar dan gebeurd er helemaal niets. Geen foutmelding, maar ook de mailtjes met bijlage worden niet getoond.
 
Laatst bewerkt door een moderator:
Ok, dan was dat antwoord tekort door de bocht. Ik zal er vanavond eens wat uitgebreider naar kijken als een ander me niet voor is.
 
Daar lijkt het helaas wel op. Desalniettemin bedankt!
Ik ben benieuwd waar je vanavond tegen aanloopt.
 
Laatst bewerkt door een moderator:
Er is niemand die me kan helpen om de oplossing voor het bovenstaande probleem te vinden?
 
Purrel,

Ik weet er ook niet veel van maar hij filterd op kolom 2.
Als je dit nu eens veranderd naar kolom 1 waar de namen staan, help dit?
Code:
'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
    FieldNum = [COLOR="red"]2[/COLOR]    'Filter column = B because the filter range start in column A
 
Nee, want dan werkt het stuk code waar gezocht wordt naar unieke emailadressen niet meer... :(
Niettemin bedankt voor het meedenken, dat stel ik op prijs.

Iemand anders nog ideeën?
 
Mijn dank is groot. Dit is precies wat ik wilde. :thumb:

Nu is het alleen nog een kwestie van deze macro in mijn orginele bestand plakken. Maar dat moet wel lukken. :)
 
Status
Niet open voor verdere reacties.

Nieuwste berichten

Terug
Bovenaan Onderaan