Verzend e-mails via een Excel-lijst vanuit Word

[Kozzmozz]

Ik wil gepersonaliseerde e-mails sturen vanuit Word via een mailmerge met een Excel-lijst.

Echter bots ik tegen volgende probleem aan; sommige e-mails hebben meerdere bestemmelingen.
Deze e-mailadressen staan in aparte kolommen, maar in de mailmerge van Word kan ik maar één kolom selecteren (bijv. E-mailadres 1).

E-mailadres 1	E-mailadres 2	E-mailadres 3
[e-mail]	[e-mail]	[e-mail]

Ik heb getracht om in Excel de verschillende e-mailadressen in één kolom samen te voegen.
Zo zet ik in de kolom de e-mailadressen alsvolgt; [e-mail]; [e-mail]; [e-mail]

Maar wat ik ook doe, de mailmerge wil niet vertrekken uit Word.
Wie kan mij helpen?

[Paultje3181]

Is het de bedoeling dat de mails naar alle 3 gaan? of alleen naar de 1e? In het 1e geval zou je met VBA een script kunnen schrijven die een rij invoegt als er een 2e of 3e mail adres staat. Hier kopieer je dan vervolgens de gegevens van rij 1 en mail 2 als mail-adres. Dit vervolgens ook voor 3 doen.

Is er een max aan het aantal mailadressen?

[Okkienoot]

Even alle emailadressen kopiëren en dan middels plakken speciaal => Transponeren in één kolom zetten.

Dan werkt je merge wel.

[Kozzmozz]

Het is weldegelijk een unieke e-mail per firma die naar 3 verschillende e-mailadressen moeten verzonden worden. Vervolgens de volgende regel met bijv. maar 2 verschillende e-mailadressen en zo verder...

Firmanaam	E-mailadres 1	E-mailadres 2	E-mailadres 3
Firma X	[e-mail]	[e-mail]	[e-mail]
Firma Y	[e-mail]	[e-mail]
Firma Z	[e-mail]

[Okkienoot]

Volgens mij is hier geen standaard oplossing voor. Je zou http://www.wordbanter.com...1869ac172db253f8a8&t=5012 eens door kunnen nemen. Daar lukt het iemand middels een Macro geloof ik.

[Paultje3181]

Visual Basic:

Sub Multiplemail()
Dim LastRow As Long
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
Dim i As Long
i = 2
Dim j As Long
j = 2
Do While i <= LastRow
    If Not Cells(j, 4).Value = "" Then
        Cells(j, 1).Select
        ActiveCell.Offset(1).EntireRow.Insert
        Cells(j + 1, 1).Value = Cells(j, 1).Value
        Cells(j + 1, 2).Value = Cells(j, 4).Value
        j = j + 2
        LastRow = LastRow + 1
    Else
        j = j + 1
    End If
    If Not Cells(i, 3).Value = "" Then
        Cells(i, 1).Select
        ActiveCell.Offset(1).EntireRow.Insert
        Cells(i + 1, 1).Value = Cells(i, 1).Value
        Cells(i + 1, 2).Value = Cells(i, 3).Value
        i = i + 2
        LastRow = LastRow + 1
    Else
    i = i + 1
    End If
Loop

End Sub

Doet wat het moet doen, volgens mij (niet heel uitgebreid getest), als je er nog meer zou hebben (4 of 5 bijv), kun je k en l toevoegen volgens hetzelfde principe als j. Vervolgens je mailmerge via E-mailadres 1