Split Data from Mergefield into seperate rows

Kalü · #1 06-09-2022, 11:02 AM

Hey there,

I have a mailmerge document which creates a single table for each client.

In row 14 there is one Mailmerge field called Partners. There are many names sepreated by commata. Is it possible to split these names into rows (one row for each name) so that word creates automatically new rows?

I tried it with vba and macro recording but nothing is working out reliable and im so sad right now because i have to do this work every week all manually -.-

macropod · #2 06-10-2022, 07:14 AM

Mailmerge can't do that.

A macro would be needed, but you haven't told us enough about the table for a solution to be developed. For example:
Is it the first table for each record?
In which column are the partner names?

Kalü · #3 06-13-2022, 10:25 AM

Hi Macropod,

thank you very much for your reply! Tbh I actually tried to simplyfy my problem a bit. Let me tell you everything to make it easier to understand:

I get a bunch of word files every week. Every Word file contains one table which is my "recipients data" for mail merging. I manually search and clean up each table in those word files and copy it to my "Source.docx".

My mail merge "Master.docx" is of course another word file which is an empty file with a completly other table where i put my mergefields in the diferent cells. (To make it even harder, I have two master files: one has a green table "master1.docx" and the other one has a red table "master2.docx".
But the tables are identically only the filling color is different.

So I create two mail merg documents, depending on the last column in "Source.docx".

What I got so far in my code below:

1. Create both mail merged documents (green and red)

2. Split the date in the master tables last row (left and right cell) ---> Call SplitDate()

3. Insert NewRows for all the Names ("eigene Berater") in master tables row 14 ff ---> NewRowsAJ()

Column 4 in Source.docx has to be splitted into:
a) Row 14 f for every name before "(Federführung)" or "(gemeinsame Federführung)"

b) 18 ff for every name behind "(Federführung)" or "(gemeinsame Federführung)"

In the master/mailmerged documents it is not allowed to write two or more names together in one row, so I have to split a) and b) itself have to into seperate rows for each name.

4. Replace Section Breasks that were created from words mail merge --->Call ReplaceSectionBreaks()

5. Insert all tables in the final document to be submitted.

Number 3 is my problem because its not working reliable and I dont know why -.-
Thats why I want o replace that step with a Mergfield function to split aftere each comma somehow....

Code:

Sub test()
'
'
'
'master1.docx =green table is open:::::::::

    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:= _
        "C:\Users\.....\Source.docx", ConfirmConversions _
        :=False, ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
        Connection:="", SQLStatement:="", SQLStatement1:="", SubType:= _
        wdMergeSubTypeOther
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With

      .Execute Pause:=False
    End With
'-----------------------------------------------------------------
'
Call SplitDate()
Call NewRowsAJ
Call ReplaceSectionBreaks


'--------------------------------------------------------------------
'::::SAVE
       
       ActiveDocument.SaveAs FileName:="C:\Users\.....\1.docx"
       ActiveWindow.Close
'------------------------------------------------------------------------    
'Master2=red table::::::::::
    Documents.Open FileName:="C:\Users\.....\Master2.docx"
    ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:= _
        "C:\Users\azem\Work Folders\Desktop\BDC\Legal500_Quelle.docx", ConfirmConversions _
        :=False, ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
        Connection:="", SQLStatement:="", SQLStatement1:="", SubType:= _
        wdMergeSubTypeOther
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
       .Execute Pause:=False
    End With
    
'--------------------------------------------------------------------------

Call SplitDate()
Call NewRowsAJ
Call ReplaceSectionBreaks

'----------------------------------------------------------------------

'::::SAVE
       ActiveDocument.SaveAs "C:\Users\.......\2.docx"
       ActiveWindow.Close   
       

'Insert 1.docx (green tables) and 2.docx (red tables) in finalDoc at Boookmark's postion

Documents.Open FileName:="C:\Users.......\FinalDocument.docx"

ActiveDocument.Bookmarks("grün").Select

    Selection.InsertFile FileName:="C:\Users\.......\1.docx", Range:="", ConfirmConversions _
        :=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="C:\Users\a.......\2.docx", Range:="", ConfirmConversions:= _
        False, Link:=False, Attachment:=False

End Sub

-------------------------------------------------------------------------------
Sub SplitDate()

Dim keyWord, data As String
Dim rowCount As Long
Dim splitArray() As String



keyWord = "Startdatum"
tableCount = ActiveDocument.Tables.count

For i = 1 To tableCount

rowCount = ActiveDocument.Tables(i).Rows.count

    For j = rowCount To 1 Step -1

        data = ActiveDocument.Tables(i).Cell(j, 1).Range.Text
        data = Replace(data, vbCr, "")
        data = Left(data, Len(data) - 1)

        If (data = keyWord) Then

            data = ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text
            data = Replace(data, vbCr, "")
            data = Left(data, Len(data) - 1)

            ''Variante VON XYZ BIS XYZ '''
            If (InStr(data, "-") > 0) Then
                splitArray() = Split(data, "-")
                ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text = splitArray(0)
                ActiveDocument.Tables(i).Cell(j + 1, 2).Range.Text = splitArray(1)
                Exit For
            End If
            '''
            ''Variante Fortlaufend
            If (data = "Fortlaufend") Then
                ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text = data
                ActiveDocument.Tables(i).Cell(j + 1, 2).Range.Text = ""
                Exit For
            End If
            '''
            ''Variante "seit XYZ"
            If (InStr(data, "eit") > 0) Then
                ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text = data
                ActiveDocument.Tables(i).Cell(j + 1, 2).Range.Text = ""
                Exit For
            End If
            '''
            ''Variante "bis XYZ"
            If (InStr(data, "bis") > 0) Then
                ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text = ""
                ActiveDocument.Tables(i).Cell(j + 1, 2).Range.Text = data
                Exit For
            End If
            ''Variante nur datum (Enddatum?)
            ActiveDocument.Tables(i).Cell(j + 1, 1).Range.Text = ""
            ActiveDocument.Tables(i).Cell(j + 1, 2).Range.Text = data
            Exit For
        End If
    Next
Next
End Sub

---------------------------------------------------------------------------------

Sub NewRowsAJ()
'only sometimes working :(
    Dim dataArray() As String
    Dim splitArray() As String
    Dim data As String
    Dim i, x, z, count, tableCount, lastIndex, lastCell, b, callY, preCell As Long
    
    'Anzahl der vorhandenen Zellen unter der Federführende etc., die mit Werte eingetragen werden kann.
    preCell = 3
    'Zählt die Tabellen durch.
    tableCount = ActiveDocument.Tables.count

'Loop durch die Tabellen.
For i = 1 To tableCount
    
    callY = 14
    'Holt sich den langen String aus der Zelle.
    data = ActiveDocument.Tables(i).Cell(callY, 1).Range.Text
    
    'Absatz/Zeilenumbruch abfangen...
    data = Replace(data, vbCr, "")
    data = Left(data, Len(data) - 1)

    'Großer String wird geteilt.
    dataArray = Split(data, "(")
      
    'Split1 wird aufgeteilt, Spalten zugewiesen und reingeschrieben.
    splitArray = Split(dataArray(0), ", ")
    lastIndex = UBound(splitArray) + 1
    If lastIndex > preCell Then
    For z = 3 To lastIndex
        For count = 1 To 3
            ActiveDocument.Tables(i).Cell(callY, count).Range.Cells.Split NumRows:=2, NumColumns:=1, MergeBeforeSplit:=False
        Next
    Next
    End If
    
    For z = 0 To lastIndex - 1
        ActiveDocument.Tables(i).Rows(callY).Height = 9.75
        ActiveDocument.Tables(i).Cell(callY, 1).Range.Text = splitArray(z)
        callY = callY + 1
    Next
    If UBound(splitArray) = 0 Then
        callY = callY + 1
    End If
    
    'Abfrage ob der große String gesplittet wurde.
    If UBound(dataArray) = 1 Then
        callY = callY + 2
   
'Split2 wird aufgeteilt, Spalten zugewiesen und reingeschrieben.
        splitArray = Split(dataArray(1), ", ")
        lastIndex = UBound(splitArray)
        If UBound(splitArray) = 0 Then
        callY = callY + 1
        End If
        
        For z = 2 To lastIndex
            For count = 1 To 3
            ActiveDocument.Tables(i).Cell(callY, count).Range.Cells.Split NumRows:=2, NumColumns:=1, MergeBeforeSplit:=False
            Next
        Next
        
        For z = 1 To lastIndex
            ActiveDocument.Tables(i).Rows(callY).Height = 9.75
            ActiveDocument.Tables(i).Cell(callY, 1).Range.Text = splitArray(z)
            callY = callY + 1
        Next
    End If
Next
End Sub


-----------------------------------------------------------------------------

Sub ReplaceSectionBreaks()
    'reliably replace section breaks with page breaks
    'even if they're followed by tables
    Dim rg As Range
    Set rg = ActiveDocument.Range
    With rg.Find
        .Text = "^b"
        .Wrap = wdFindStop
        While .Execute
            rg.Delete
            rg.InsertBreak Type:=wdPageBreak
            rg.Collapse wdCollapseEnd
        Wend
    End With
End Sub

macropod · #4 06-13-2022, 05:59 PM

It seems to me you're trying to deal with the problem from the wrong end. It would be far simpler to correct the data before merging. Try the following macro on your source document:

Code:

Sub SourceTableReformat()
Application.ScreenUpdating = False
Dim r As Long, x As Long, y As Long, Rng As Range, StrTxt As String
With ActiveDocument.Tables(1)
  For r = .Rows.Count To 2 Step -1
    With .Rows(r)
      StrTxt = Split(.Cells(4).Range.Text, vbCr)(0)
      x = UBound(Split(StrTxt, ","))
      If x > 0 Then
        Set Rng = .Range
        For y = 1 To x - 1
          Rng.Collapse wdCollapseEnd
          Rng.FormattedText = .Range.FormattedText
          Rng.Cells(4).Range.Text = Trim(Split(StrTxt, ",")(y))
        Next
        .Cells(4).Range.Text = Trim(Split(StrTxt, ",")(0))
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

Thread Tools
Show Printable Version Email this Page
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Delete blank table rows in merged document and split document in docx and pdf based on excel rows	Alex1s85	Word VBA	5	05-22-2021 12:05 PM
Split data in cells and duplicate rows	ballpoint	Excel Programming	6	02-07-2018 05:52 PM
Blank Rows in Table populated through Conditional IF statemement MergeField options in Word	gideonpm	Mail Merge	3	12-22-2016 01:20 PM
Macro Winword mailmerge split printpage with mergefield as filename	pca	Word VBA	2	02-28-2014 02:43 PM
Can I do this? sorting data in seperate columns	shumonsaha	Excel	0	07-04-2010 03:05 AM