Microsoft Office Forums - View Single Post

kilroy · 01-10-2018, 11:49 AM

***This issue was raised on a different forum first but marked as closed with no real solution.***

I'm hoping someone here might have some ideas. I have some code (written by Graham) that unmerges vertically merged cells however it only works on column 1. 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. I'm wondering if any here might have some suggestions? I've attached 2 documents: R1 is how it works now and R2 is an example of other columns with vertically merged cells before and after. There will always be at least one column without any cells merged vertically. Thanks for any suggestions.

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