Microsoft Office Forums - View Single Post - [Solved] Split Data from Mergefield into seperate rows

Kalü · 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