Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Jan 2005
    Thanked 0 Times in 0 Posts

    Column merge question (MS Office 97)


    I have the following problem:

    In a MS Word 97 table I need to select several rows and merge each columns in that selection based on the value of the first column: "merge the cells by columns vertically, as long as there is an empty cell in column 1 under a cell in column 1, that contains some text".

    For example, with a table like:

    Cell(1,1) ="A" Cell(1,2)="B" Cell (1,3)="C"
    Cell(2,1) ="" Cell(2,2) ="D" Cell (2,3)="E"
    Cell(3,1) =" F" Cell(3,2)="G" Cell (3,3)="H"
    Cell(4,1)="" Cell(4,2)="I" Cell (4,3)="J"
    Cell(5,1)="" Cell(5,2)="K" Cell (5,3) ="L"

    Note: Cells (2,1), (4,1) and (5,1) are empty.

    must be merged to:
    Cell(1,1)="A" Cell(1,2) ="B^pD" Cell (1,3) ="C^pE"
    Cell(2,1) ="F" Cell(2,2)=" G^pI^pK" Cell (2,3) ="H^pJ^pL"

    Can anybody help me please with some VBA code?

    Catalin Florean,
    Bucharest, ROMANIA.

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Thanked 31 Times in 31 Posts

    Re: Column merge question (MS Office 97)

    Welcome to Woody's Lounge!

    The following macro works OK in the limited testing I did.

    Sub MergeThem()
    ' Variables
    Dim tbl As Table
    Dim cel As Cell
    Dim lngRow As Long
    Dim lngRowCount As Long
    Dim lngColCount As Long
    Dim i As Long
    Dim j As Long
    Dim arr(1 To 1000, 1 To 2) As Long

    ' Initizalize
    Set tbl = Selection.Tables(1)
    lngRowCount = tbl.Rows.Count
    lngColCount = tbl.Columns.Count

    ' First loop through column 1 to store information in array
    For lngRow = 1 To lngRowCount
    If Len(tbl.Cell(lngRow, 1).Range) = 2 Then
    ' Blank cell
    arr(i, 2) = arr(i, 2) + 1
    ' Non-blank cell
    i = i + 1
    arr(i, 1) = lngRow
    arr(i, 2) = 0
    End If
    Next lngRow

    ' Loop through array, backwards
    For lngRow = i To 1 Step -1
    ' Loop through columns
    For j = 1 To lngColCount
    If arr(lngRow, 2) > 0 Then
    tbl.Cell(arr(lngRow, 1), j).Select
    Selection.MoveDown Unit:=wdLine, Count:=arr(lngRow, 2), Extend:=wdExtend
    End If
    Next j
    Next lngRow

    ' Clean up
    Set tbl = Nothing
    Erase arr
    End Sub

    Click somewhere in the table before running the macro. Please test thoroughly on a copy of your document.

Posting Permissions

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