table columns question

[Pinaceous]

Hi All,

I am wondering, if there is a way to combine columns in a table?


For example, if there are 7 table columns across 7 rows, can one merge its "cells" to one column?


Please let me know, if there is a method to accomplish this task.

Many thanks in advance.

R/
Pinaceous

 

[MartyS]

Hi All,

I am wondering, if there is a way to combine columns in a table?


For example, if there are 7 table columns across 7 rows, can one merge its "cells" to one column?


Please let me know, if there is a method to accomplish this task.

Many thanks in advance.

R/
Pinaceous

This was something I had to do so often.. so I created the following:


Note: Edit the CONSTS to make sure the SHEETNAME and DATA START POSITIONS are correct

Option Explicit


Sub CopyColumn()






    Const SheetName = "CopyColumn"      'The name of the worksheet / worksheet tab with your data in it


    Const DataStartRow = 2              'The ROW were the DATA starts. (The 1st line of DATA will be just below the COLUMN HEADINGS)
                                        'thus if your column headings are in row 1, your data starts in row [2]


    Const DataStartCol = 1              'The COLUMN where the DATA starts. (If your data begins in A1, it'll be column [1]
                                        'if you data begins in D1, it'll be column[4]  (A=1, B=2, C=3, D=4.. and so on)


    Const NoOfCols = 7                  'The number of columns of data to work with


    Const DataMaxRow = 1048576          'Excel MAX row - do not alter


    Const DataPutCol = 10               'Column you want the appended column data to go in
    Const DataPutRow = 2                'Row you want the appended column data to start at






    Dim Cntr As Integer
    Dim RowEnd() As Integer
    Dim AppendRow As Integer


    'Do CONST error trapping
    If DataStartRow < 1 Then
        MsgBox "The Start Row of your data [DataStartRow CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataStartCol < 1 Then
        MsgBox "The Start Column of your data [DataStartCol CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If NoOfCols < 2 Then
        MsgBox "The Number of Columns of data [NoOfCols CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataPutCol <= (NoOfCols + DataStartCol - 1) Then
        MsgBox "The Output Column needs to be further to the right of the data columns [DataPutCol CONST] must be greater than [DataStartCol CONST]", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    If DataPutRow < 1 Then
        MsgBox "The Output Row [DataPutRow CONST] must be 1 or higher", vbCritical & vbOKOnly, "Const ERROR"
        Exit Sub
    End If
    
    
    
    Application.ScreenUpdating = False
    

    ReDim RowEnd(1 To NoOfCols)


    'Get the End Row of each column of data
    For Cntr = 1 To NoOfCols
        RowEnd(Cntr) = Sheets(SheetName).Range(Cells(DataStartRow, DataStartCol + Cntr - 1).Address, Cells(DataMaxRow, DataStartCol + Cntr - 1).Address).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Next Cntr


    'Copy the data .. appending to just one column
    For Cntr = 1 To NoOfCols
        If Cntr = 1 Then
            Sheets(SheetName).Range(Cells(DataStartRow, DataStartCol + Cntr - 1).Address, Cells(RowEnd(Cntr), DataStartCol + Cntr - 1).Address).Copy Sheets(SheetName).Range(Cells(DataPutRow, DataPutCol).Address)
            AppendRow = DataPutRow + RowEnd(Cntr) - 1
          Else
            Sheets(SheetName).Range(Cells(DataStartRow, DataStartCol + Cntr - 1).Address, Cells(RowEnd(Cntr), DataStartCol + Cntr - 1).Address).Copy Sheets(SheetName).Range(Cells(AppendRow, DataPutCol).Address)
            AppendRow = AppendRow + RowEnd(Cntr) - 1
        End If
        
    Next Cntr

   
    Application.ScreenUpdating = True


End Sub

 

[Pinaceous]

Wow, hey thanks MartyS!

That's incredible! I'll be honest, I didn't think the answer would be vba and/or that intricate.

I'm going to have to put some real thought into this before I can truly comment as to the application.

Thanks again!
Paul

 

[MartyS]

Wow, hey thanks MartyS!

That's incredible! I'll be honest, I didn't think the answer would be vba and/or that intricate.

I'm going to have to put some real thought into this before I can truly comment as to the application.

Thanks again!
Paul

There are probably other ways of doing it, but it was literally just a few lines of code (with some error handling thrown in) and saved hours.

It's there if you need it.