VBA - Combine multiple columns into single column

[lj97]

G'day


I am needing to combine data from multiple columns into a single column.

The column name/header is in cell A1.

All data present needs to be in Column A.

I am needing each cell to only include one fruit name.

The data set is dynamic and changes regularly (i.e. sometimes there are more columns, sometimes there are less).

If anyone needs more info I am happy to provide it!

Thanks in advance

P.s. I have attempted a few things in VBA. I have gotten close, but I am stuck on what to do when there is only one entry in a column (e.g. column F having only "Apple" in this example).

Combine columns into single column.xlsm
	A	B	C	D	E	F
1	Fruit Name	Melon	Mango	Apple	Pear	Apple
2	Orange	Melon	Mango	Mango	Mango
3	Apple	Pear	Mango	Mango
4	Pear	Pear	Melon	Banana
5	Apple	Pear	Melon	Banana
6	Apple	Melon	Melon
7	Apple	Melon	Melon
8	Orange	Pear	Melon
9	Apple	Melon	Banana
10	Apple	Apple
11	Melon	Melon
12	Apple	Melon
13	Apple	Melon
14	Apple	Pear
15	Apple	Pear
16	Grapes	Pear
17	Apple	Melon
18	Apple	Melon
19	Apple	Banana
20	Orange	Banana
21	Apple	Banana
22	Apple	Melon
23	Apple	Melon
24	Apple	Melon
25	Apple	Pear
26	Apple	Melon
27	Apple	Apple
28	Apple
29	Apple
30	Apple
31	Apple
32	Apple
33	Apple
34	Orange
35	Apple
36	Apple
37	Orange
38	Apple
39	Grapes
40	Orange
41	Pear
Sheet1

 

[bebo021999]

There are six columns. Which are source columns and which is output column?

 

[Z51]

This might help...

Sub lj97()
Dim lastrow As Long, lastcol As Long, nextrow As Long, i As Long
lastcol = Range("A1").End(xlToRight).Column
nextrow = Range("A" & Rows.Count).End(xlUp).Row + 1

For i = 2 To lastcol
    lastrow = Cells(Rows.Count, i).End(xlUp).Row
    Cells(nextrow, 1).Resize(lastrow, 1).Value = Cells(1, i).Resize(lastrow, 1).Value
    nextrow = nextrow + lastrow
Next i
End Sub

 

[Peter_SSs]

You possibly do not have it yet but IF you happen to have the TOCOL function in your version, another way would be ..

Sub IntoOneColumn()
  With Range("A1").CurrentRegion
    .Resize(.SpecialCells(xlConstants).Count, 1).Value = Evaluate("=TOCOL(" & .Address & ",1,1)")
  End With
End Sub