Combining multiple collumns to create a single consolidated list

[jonjonjonjon]

Hi guys,

Is there a way to pick out cells that contain text from multiple columns and aggregate them into one single list?

eg: Problem:[TABLE="width: 500"]
<tbody>[TR]
[TD]red[/TD]
[TD][/TD]
[TD]circle[/TD]
[TD][/TD]
[TD]table [/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]square[/TD]
[TD][/TD]
[TD]book[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[TD][/TD]
[TD]triangle [/TD]
[TD][/TD]
[TD]pencil[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]green[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Result needed:

[TABLE="width: 500"]
<tbody>[TR]
[TD]red[/TD]
[/TR]
[TR]
[TD]Blue[/TD]
[/TR]
[TR]
[TD]green[/TD]
[/TR]
[TR]
[TD]circle[/TD]
[/TR]
[TR]
[TD]square[/TD]
[/TR]
[TR]
[TD]triangle [/TD]
[/TR]
[TR]
[TD]table [/TD]
[/TR]
[TR]
[TD]book[/TD]
[/TR]
[TR]
[TD]pencil[/TD]
[/TR]
</tbody>[/TABLE]

 

[jonjonjonjon]

Hi, great, thanks again! I haven't done vba before but this will be a good opportunity to give a go, so lets start with that!

 

[XOR LX]

I'll give you both solutions, so then you can decide for yourself.

In both cases I've highlighted in red the parts that you will need to amend. As it stands, both will return all non-blank entries from the ranges C1:C10, I1:I10 and O1:O10 from three sheets named "Sheet1", "Sheet2" and "Sheet3", in the case of the VBA into a sheet named "Master" beginning in cell A2, and in the case of the formulas wherever you decide to place the initial formula.

VBA

Sub ManytoOne()

Dim Rng     As Range
Dim Sht     As Variant
Dim Ws      As Worksheet
Dim r       As Range

Application.ScreenUpdating = False

For Each Sht In Array("[COLOR=#ff0000]Sheet1[/COLOR]", "[COLOR=#ff0000]Sheet2[/COLOR]", "[COLOR=#ff0000]Sheet3[/COLOR]")
    Set Ws = Worksheets(Sht)
    For Each r In Ws.Range("[COLOR=#ff0000]C1:C10[/COLOR],[COLOR=#ff0000]I1:I10[/COLOR],[COLOR=#ff0000]O1:O10[/COLOR]")
        If r.Value <> "" Then
            With Worksheets("[COLOR=#ff0000]Master[/COLOR]")
                With .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                    .Value = r.Value
                End With
            End With
        End If
    Next r
Next Sht

Application.ScreenUpdating = True

End Sub

Formulas

First, go to Name Manager (Formulas tab) and make the following definitions:

Name: SheetList
Refersto: ={"Sheet1","Sheet2","Sheet3"}

Name: First_Col
Refers to: =$C$1:$C$10

Name: Col_Inc
Refers to: ={0,6,12}

This should be a comma-separated array containing integers which indicate the column-offsets to be applied. My choice, for example, means that the ranges to be considered across all sheets are:

$C$1:$C$10 offset by 0 columns, i.e.$C$1:$C$10
$C$1:$C$10 offset by 6 columns, i.e. $I$1:$I$10
$C$1:$C$10 offset by 12 columns, i.e. $O$1:$O$10

Name: Arry1
Refersto: =ROW(INDIRECT("1:"&ROWS(First_Col)*COUNT(Col_Inc)*COUNTA(SheetList)))

Name: Arry2
Refersto: =T(INDIRECT("'"&SheetList&"'!"&TEXT(MODE.MULT(10^5*ROW(First_Col)+COLUMN(First_Col)+Col_Inc,10^5*ROW(First_Col)+COLUMN(First_Col)+Col_Inc),"R0C00000"),0))

After which the required array formula** is:
<!--[endif]-->
=IF(ROWS($1:1)>SUM(0+(Arry2<>"")),"",INDEX(INDEX(Arry2,N(IF(1,1+INT((Arry1-1)/COUNTA(SheetList)))),N(IF(1,1+MOD(Arry1-1,COUNTA(SheetList))))),SMALL(IF(INDEX(Arry2,N(IF(1,1+INT((Arry1-1)/COUNTA(SheetList)))),N(IF(1,1+MOD(Arry1-1,COUNTA(SheetList)))))<>"",Arry1),ROWS($1:1))))

and copied down until you get blanks for the results.

Regards


**Array formulas are not entered in the same way as 'standard' formulas. Instead of pressing just ENTER, you first hold down CTRL and SHIFT, and only then press ENTER. If you've done it correctly, you'll notice Excel puts curly brackets {} around the formula (though do not attempt to manually insert these yourself).

 

[jonjonjonjon]

Thanks a million! That VBA worked like a charm. (now to figure out how it works...)

Thanks again for the help

Kind regards

 

[XOR LX]

You're welcome!

Cheers

 

[jonjonjonjon]

Hi XOR LX, just on a side note - While the VBA takes the columns and puts it into a single list, is it possible to take along the neighbouring lets say 2 columns of info related to it. (and for it to do all the above does)

Problem:

[TABLE="width: 501"]
<tbody>[TR]
[TD]name[/TD]
[TD]Info 1[/TD]
[TD]Info 2[/TD]
[TD][/TD]
[TD]name[/TD]
[TD]Info 1[/TD]
[TD]Info 2[/TD]
[/TR]
[TR]
[TD]x[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD]r[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD]f[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]v[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD]s[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[/TR]
</tbody>[/TABLE]

solution:
[TABLE="width: 245"]
<tbody>[TR]
[TD]names[/TD]
[TD]Info 1[/TD]
[TD]Info 2[/TD]
[/TR]
[TR]
[TD]x[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]v[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]r[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[/TR]
[TR]
[TD]f[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]s[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]0[/TD]
[/TR]
</tbody>[/TABLE]

 

[XOR LX]

Sure.

It's the i = 1 to 3 part which dictates that the column ranges specified plus the two to the right are considered.

Sub ManytoOne()

Dim Rng             As Range
Dim Sht             As Variant
Dim Ws              As Worksheet
Dim r               As Range
Dim i               As Long

Application.ScreenUpdating = False

For Each Sht In Array("Sheet1", "Sheet2", "Sheet3")
    Set Ws = Worksheets(Sht)
    For Each r In Ws.Range("C1:C10,I1:I10,O1:O10")
        If r.Value <> "" Then
            With Worksheets("Master")
                [COLOR=#ff0000]For i = 1 To 3[/COLOR]
                    With .Cells(.Cells(Rows.Count, i).End(xlUp).Row + 1, i)
                        .Value = r.Offset(0, i - 1).Value
                    End With
                Next i
            End With
        End If
    Next r
Next Sht

Application.ScreenUpdating = True

End Sub

Regards

 

[jonjonjonjon]

Awesome!! thanks again XOR LX!

 

[XOR LX]

No worries! Cheers!