Consulting

Results 1 to 13 of 13

Thread: Select and Merge Specific Columns

  1. #1

    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:

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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Hmmm.


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

  4. #4
    Post a sample of the text you are trying to process.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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

  6. #6
    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:

    2017-08-25 16_13_54-Macros [Read-Only] - Microsoft Word.jpg

    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:

    2017-08-25 16_06_36-Document6 - Microsoft Word.png

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

  7. #7
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  8. #8
    Ah, yep, that makes sense...

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

    5992.jpg

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

  9. #9
    We have already been there. Is there another table in your document?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  10. #10

  11. #11
    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?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  12. #12
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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

  13. #13

    Post

    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •