Select and Merge Specific Columns

Hello,

I'm trying to create a macro that will:

1. Convert text into two columns, separated at tab character.
(This can be applied to entire document; the text I'm using for this would only ever result in two columns.)

2. Select first column, merge cells, AutoFit to Contents.

3. Select second column, merge cells, AutoFit to Contents.

Is this possible?

Best I can come up with for the first part:

Code:

---

'convert text into tables
    Selection.WholeStory
    Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2
        With Selection.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleFirstColumn = True
        End With

---

I can't figure out how to select specific columns once that's done...

Thanks for any help!

How about

Code:

---

With Selection.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleFirstColumn = True
        With .Columns(1)
            .Cells.Merge
            .AutoFit
        End With
        With .Columns(2)
            .Cells.Merge
            .AutoFit
        End With
    End With

---

Hmmm.


"Run-time error '5992':
Cannot access individual columns in this collection because the table has mixed cell widths."

Post a sample of the text you are trying to process.

When I run Grahams code it works perfectly for word 2016 with no issues. Only when the document has a table in it does this code give an error message.

Code:

---

Sub Test2Columns()
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2
With Selection.Tables(1)
    .Style = "Table Grid"
    .ApplyStyleHeadingRows = True
    .ApplyStyleFirstColumn = True
    With .Columns(1)
        .Cells.Merge
        ‘.AutoFit
    End With
    With .Columns(2)
        .Cells.Merge
        ‘.AutoFit
    End With
End With
End sub

---

Appreciate the help so far! Now I seem to get:

"Run-time error '5941':
The requested member of the collection does not exist."

Sample text below – the whole purpose is to separate the timecodes into a separate column. (There's actually three spaces between the timecodes and the text in the intended second column, which don't seem to be replicated in quotes text):

Quote:

---

15:57:37 When baseball is no longer fun, it's no longer a game. And so, I've played my
15:57:44 last game of ball.
15:57:45
15:57:45 (APPLAUSE)
15:57:45
15:57:47 And so, I've played my last game of ball.
15:57:50
15:57:50 (APPLAUSE)
15:57:50
15:57:50 And so, I've played my last game of ball.

---

So I'd first find three spaces and replace with a tab. But note that the text still contains some potentially ... limiting ... formatting:

Attachment 20172

And so, on further inspection, even my initial request wouldn't have helped – merging the cells from each column won't maintain the spacing of the second column if there are blank rows. It turned the above into:

Attachment 20171

Anyway, now it seems that it would be sufficient to merely remove the Inside Horizontal Borders, rather than merging the cells within each column, if anybody can help out with that...?

The issue with your table is that because some of the lines don't have a tab character, only the first column is filled, so when you merge the columns, the empty cells are moved up. You need to ensure that there is something in the second cell for this to work e.g.

Code:

---

Sub Macro1()
Dim oCell As Cell
Dim oRng As Range
    ActiveDocument.Range.ConvertToTable _
            Separator:=wdSeparateByTabs, _
            NumColumns:=2
    With ActiveDocument.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleFirstColumn = True
        For Each oCell In .Columns(2).Cells
            If Len(oCell.Range) = 2 Then
                Set oRng = oCell.Range
                oRng.End = oRng.End - 1
                oRng.Text = "-"
            End If
        Next oCell
        With .Columns(1)
            .Cells.Merge
            .AutoFit
        End With
        With .Columns(2)
            .Cells.Merge
            .AutoFit
        End With
    End With
lbl_Exit:
    Set oCell = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Ah, yep, that makes sense...

So when I tried that macro, it gets to this point:

Attachment 20175

..then:

"Run-time error '5992':
Cannot access individual columns in this collection because the table has mixed cell widths."

When I select "Debug", it highlights this line:

Code:

---

For Each oCell In .Columns(2).Cells

---

We have already been there. Is there another table in your document?

No.

Then the code shouldn't fail if the document is as described. Can you post the document itself?
Note that VBA will store up error conditions. Reboot the PC and try again.
It looks like a subtitle set for a movie. That being the case, have you investigated subtitle editors?

This is a variation of mine of a code posted by Macropod. It will only work if the text does actually have 3 spaces as stated above.

Code:

---

Sub PutInTable()
    Application.ScreenUpdating = False
    With ActiveDocument.Range
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchWildcards = True
            .Text = "[\-]{5,}@[^13^l]"
            .Replacement.Text = ""
            .Execute Replace:=wdReplaceAll
            .Text = "([0-9/]{10}, [0-9:]{5}) ([!^13^l]@)[^13^l]([!^13^l]@[^13^l])"
            .Replacement.Text = "\2^t\1^t\3"
            .Text = "  "
            .Replacement.Text = "vbTab"
            .Execute Replace:=wdReplaceAll
        End With
       
        .InsertBefore "Time" & vbTab & "Message" & vbTab
        .ConvertToTable Separator:=vbTab, NumColumns:=2, Format:=wdTableFormatGrid1, _
        ApplyHeadingRows:=True, AutoFit:=True, AutoFitBehavior:=wdAutoFitWindow
    End With
    Application.ScreenUpdating = True
End Sub

---

Thanks for all your help.

So, the paragraphs which contained timecodes but no other text did not contain three spaces...

Probably a moronic solution but, after various experimentation, this worked:

Code:

---

Sub converttotable()

'add three spaces after timecodes in blank paragraphs
Dim myStoryRange As Range
For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
    .ClearFormatting
    .MatchWildcards = True
    .Execute findtext:="(^13[0-9][0-9]:[0-9][0-9]:[0-9][0-9])(^13)", ReplaceWith:="\1  ^p", Replace:=wdReplaceAll

'turn three spaces into ~ character
    .MatchWildcards = False
    .Execute findtext:="  ", ReplaceWith:="~", Replace:=wdReplaceAll
End With
Next myStoryRange

'turn ~ characters into columns
    Selection.WholeStory
    Application.DefaultTableSeparator = "~"
    Selection.ConvertToTable Separator:=wdSeparateByDefaultListSeparator, _
        NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed
    With Selection.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
    End With
   
'remove top, bottom and horizontal border lines
    Selection.Tables(1).Select
    Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
    Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
    Selection.Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderTop).LineStyle = wdLineStyleNone
    Selection.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    Selection.HomeKey Unit:=wdStory

End Sub

---