#1
|
|||
|
|||
Split Data from Mergefield into seperate rows
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 -.- |
#2
|
||||
|
||||
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?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
More information and files
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 |
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Thread Tools | |
Display Modes | |
|
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 |