Printable View
Attachment 19481
Guys I have a table with vertically merged cells in the first column. What I need to happen is that it unmerges and gives the value of the top cell to blank cells newly created. I'm not sure where to even start. Thanks in advance for any help.
Provided that the table matches exactly i.e. the same number of merged cells in each segment then the following should work
Code:Sub Macro1()
Dim oTable As Table
Dim oCell As Range, sText
Dim i As Integer
Set oTable = ActiveDocument.Tables(1)
For i = oTable.Columns(1).Cells.Count To 2 Step -1
oTable.Columns(1).Cells(i).Split 4, 1
Next i
For i = 2 To oTable.Rows.Count
Set oCell = oTable.Rows(i).Cells(1).Range
oCell.End = oCell.End - 1
If Len(oCell) > 1 Then
sText = oTable.Rows(i).Cells(1).Range.Text
Else
oCell.Text = sText
oCell.Text = Replace(oCell.Text, Chr(13), "")
End If
Next i
lbl_Exit:
Set oTable = Nothing
Set oCell = Nothing
Exit Sub
End Sub
Thanks for the reply Graham. How have you been? This table is not typical. Each merged cell could be any number of rows.
Post a table that is typical and it may be possible to help.
Attachment 19488
I do not have a typical table really. Each one is a checklist prepared and based on different manuals. The table in the attached example has differing amounts of rows behind each merged cell. I went from 2 up to 6 but there could be many more. Possibly anywhere from 2 - 25 or more. Thanks for looking into this.
Hmmm. The complicated bit is working out how many rows to split the merged cells into, and the code below could no doubt be simplified, however the following will work with your examples, but it will not work if there are any horizontally merged cells in the table.
Code:Option Explicit
Sub Macro1()
Dim i As Long, j As Long, k As Long
Dim sData() As Variant
Dim oTable As Table
Dim oCell As Cell
Dim oRng As Range
Dim sText As String
Dim sRow As String
Dim iRow As Long
Dim oColl1 As New Collection
Dim oColl2 As New Collection
Set oTable = ActiveDocument.Tables(1)
With oTable
ReDim sData(1 To .Rows.Count, 1 To .Columns.Count)
Set oCell = .Cell(1, 1)
Do While Not oCell Is Nothing
sData(oCell.RowIndex, oCell.ColumnIndex) = oCell.RowIndex & "," & oCell.ColumnIndex
Set oCell = oCell.Next
Loop
For i = 1 To UBound(sData)
sRow = ""
For j = 1 To UBound(sData, 2)
sRow = sRow & IIf(IsEmpty(sData(i, j)), "X", "A") & "|"
Next j
oColl1.Add sRow
Next i
j = 1
For i = oColl1.Count To 1 Step -1
If Left(oColl1(i), 1) = "X" Then
j = j + 1
k = j
Else
k = j
j = 1
End If
If j = 1 Then oColl2.Add k
Next i
iRow = oTable.Columns(1).Cells.Count
k = iRow
For j = 1 To oColl2.Count
For i = oColl2.Count To 1 Step -iRow
oTable.Columns(1).Cells(k).Split oColl2(j), 1
k = k - 1
Next i
Next j
End With
For i = 2 To oTable.Rows.Count
Set oRng = oTable.Rows(i).Cells(1).Range
oRng.End = oRng.End - 1
If Len(oRng) > 1 Then
sText = oTable.Rows(i).Cells(1).Range.Text
Else
oRng.Text = sText
oRng.Text = Replace(oRng.Text, Chr(13), "")
End If
Next i
lbl_Exit:
Set oColl1 = Nothing
Set oColl2 = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Works perfectly Graham. Thanks. It will take me a while to even figure out how it works. LOL.
I still can't figure this one out. I've tried everything I can think of to get this to work on columns other than the column 1. Any suggestions?
If your table's cells each contain no more than a single paragraph, the simplest approach might be to copy & paste the table into Excel, use its unmerge cells function (which Word lacks), then copy & paste the table back into Word for whatever further processing you want to do.
Thanks Paul. the merged cells will almost definitely have more than one paragraph
In that case, provided the paragraphs in a given cell have the same format, you could use Find/Replace before copying to Excel:
Find = ^p
Replace = ¶
Find = ^l
Replace = ↵
and perhaps:
Find = ^t
Replace = →
before copying & pasting into Excel, then reversing the process after copying & pasting the unmerged table back into Word.
Thanks Paul I will give this a try.
Bump. Anyone else have any ideas how to apply this to columns other than column 1?
Cross-posted at: http://www.msofficeforums.com/word-v...ged-cells.html
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq...._new_faq_item3
Paul this thread is marked as solved here so I would not expect this to be an issue. I made the comment on the other thread at Microsoft Office Forums that it had been posted elsewhere first. I'm not sure what you're trying to accomplish by posting that I crossed posted. I was very up front. The very first line on the other thread is as follows:
" ***This issue was raised on a different forum first but marked as closed with no real solution.*** "
Are you telling me that there are no different people over there that may be able to help?
The thread here was marked as solved before you even bumped it, besides which you could mark it unsolved. In any event, you didn't have the courtesy to let anyone here know you'd cross-posted, which is a requirement, and you didn't let anyone there know where you'd cross-posted, meaning they wouldn't know what discussion had gone on here beforehand.
I had modified the code initially done by Graham.
1. Code will split for all columns
2. Split cells will contain previous merged cell value (Graham code even replaced previously empty cell, now the bug is squashed)
3. Added comments where ever possible for easier understanding of what each block does
In my opinion, i can do the same work in C#.Net Word VSTO Addin in less than an hour with the help of full fledged OOPS language, rather than writing huge boilerplate code just to split cells in table with vba.
Code:Function SplitVerticalMerge()
'Created by Chandraprakash [Yoh]
Dim i As Long, j As Long, k As Long, cols As Long, m As Long
Dim sData() As Variant
Dim oTable As Table
Dim oCell As Cell
Dim oRng As Range
Dim sText As String
Dim sRow As String
Dim iRow As Long
'Rows of Merged and NonMerged cells in Table
Dim oColl1 As New Collection
'Row with number of merged cells in Table (Vertical Split Number)
Dim oColl2 As New Collection
Set oTable = ActiveDocument.Tables(1)
With oTable
'Load all the Table cell index
ReDim sData(1 To .Rows.Count, 1 To .Columns.Count)
Set oCell = .Cell(1, 1)
Do While Not oCell Is Nothing
sData(oCell.RowIndex, oCell.ColumnIndex) = oCell.RowIndex & "," & oCell.ColumnIndex
Set oCell = oCell.Next
Loop
'1. Mark the merged cell as "X"
'2. Mark the non merged cell as "A"
'3. Load the result for each row to Collection1
For i = 1 To UBound(sData)
sRow = ""
For j = 1 To UBound(sData, 2)
sRow = sRow & IIf(IsEmpty(sData(i, j)), "X", "A") ' & "|"
Next j
oColl1.Add sRow
Next i
For cols = 1 To oTable.Columns.Count
'Load one by one Row with number of merged cells in Table (Vertical Split Number)
Set oColl2 = Nothing
j = 1
For i = oColl1.Count To 1 Step -1
'"X" - Merged
If Mid(oColl1(i), cols, 1) = "X" Then
j = j + 1
k = j
'"A" - NotMerged
Else
k = j
j = 1
End If
If j = 1 Then oColl2.Add k
Next i
iRow = oTable.Columns(cols).Cells.Count
k = iRow
For j = 1 To oColl2.Count
For i = oColl2.Count To 1 Step -iRow
'cols - Column Number
'k - cell row number in column (cols)
'j - Split number for the cell (k)
'Split the cell by above attributes defined
oTable.Columns(cols).Cells(k).Split oColl2(j), 1
'1. Enter if merged cell is split (j>1)
'2. Will fill the values for split empty cell with previous merged cell value
If oColl2(j) > 1 Then
For m = 1 To oColl2(j) - 1
oTable.Columns(cols).Cells(k + m).Range.Text = oTable.Columns(cols).Cells(k).Range.Text
Next m
End If
k = k - 1
Next i
Next j
Next cols
'To avoid application freezing
DoEvents
End With
lbl_Exit:
Set oColl1 = Nothing
Set oColl2 = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oRng = Nothing
Exit Function
End Function
Thanks JOH this code works really well for unmerging all but how do have it focus on a specific column?
Remove this For loop which loops all columns in table - Remove only that two lines,
For cols = 1 To oTable.Columns.Count [place cols = 1 to n - whatever column number you want to run for]
Next cols
Btw it's Yoh and not Joh :|
Works great.
Thank you :cool:Quote:
Originally Posted by Kilroy