Select and Merge Specific Columns

[VB-AN-IZ]

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:


'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!

[gmayor]

How about


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

[VB-AN-IZ]

Hmmm.


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

[gmayor]

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

[Kilroy]

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.


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

[VB-AN-IZ]

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):


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:

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:

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...?

[gmayor]

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.


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

[VB-AN-IZ]

Ah, yep, that makes sense...

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

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:


For Each oCell In .Columns(2).Cells

[gmayor]

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

[VB-AN-IZ]

No.

[gmayor]

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?

[Kilroy]

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.


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

[VB-AN-IZ]

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:


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