Convert range to 1 column without blank cells

[Kra]

Hi all!

I need help with converting range into one column. I was able to get VBA code which works fine, but it is creating empty rows if cell from range was empty. Is there any way to ignore empty cells?

Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Joe4]

Rather than try to "guess" what your data looks like, and try to reverse engineer your code, it would be much better for us to see a sample of what your data looks like initially, and what you want the output to look like.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[Kra]

Rather than try to "guess" what your data looks like, and try to reverse engineer your code, it would be much better for us to see a sample of what your data looks like initially, and what you want the output to look like.

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Understand, here it is:

1. I got range of data in cells A3:E13. I need to have them in one clear line in one column. Code I posted lets me choose range (I select A3 to E13), then lets me choose output cell (I select J1). But the code do not ignores empty cells, it creates empty rows in Column J. I need to be able to select range with empty cells, like in this case, and move them to one Column like it is shown in mini sheet column J:

Test.xlsx
	A	B	C	D	E	F	G	H	I	J
1	Input:							Output:		VALUE 1
2										VALUE 2
3	VALUE 1	VALUE 4	VALUE 10	VALUE 18	VALUE 21					VALUE 3
4	VALUE 2	VALUE 5	VALUE 11	VALUE 19	VALUE 22					VALUE 4
5	VALUE 3	VALUE 6	VALUE 12	VALUE 20	VALUE 23					VALUE 5
6		VALUE 7	VALUE 13		VALUE 24					VALUE 6
7		VALUE 8	VALUE 14		VALUE 25					VALUE 7
8		VALUE 9	VALUE 15		VALUE 26					VALUE 8
9			VALUE 16		VALUE 27					VALUE 9
10			VALUE 17		VALUE 28					VALUE 10
11					VALUE 29					VALUE 11
12					VALUE 30					VALUE 12
13					VALUE 31					VALUE 13
14										VALUE 14
15										VALUE 15
16										VALUE 16
17										VALUE 17
18										VALUE 18
19										VALUE 19
20										VALUE 20
21										VALUE 21
22										VALUE 22
23										VALUE 23
24										VALUE 24
25										VALUE 25
26										VALUE 26
27										VALUE 27
28										VALUE 28
29										VALUE 29
30										VALUE 30
31										VALUE 31
Sheet3

 

[Joe4]

You can just add additional code to your code that selects the range you pasted to, and select the blank cells, then deletes them, shifting everything else up, like this:

Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim lr As Long
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False

'Find last row in column of Range2 with data
lr = Cells(Rows.Count, Range2.Column).End(xlUp).Row
'Remove all blanks from final paste range
Range(Cells(Range2.Row, Range2.Column), Cells(lr, Range2.Column)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

Application.ScreenUpdating = True
End Sub

 

[Fluff]

How about with a formula?
Two options, one does what your macro is doing & the other gives the data as you have shown it.

Fluff.xlsm
	A	B	C	D	E	F	G	H	I
1	Input:							Output:
2								VALUE 1	VALUE 1
3	VALUE 1	VALUE 4	VALUE 10	VALUE 18	VALUE 21			VALUE 4	VALUE 2
4	VALUE 2	VALUE 5	VALUE 11	VALUE 19	VALUE 22			VALUE 10	VALUE 3
5	VALUE 3	VALUE 6	VALUE 12	VALUE 20	VALUE 23			VALUE 18	VALUE 4
6		VALUE 7	VALUE 13		VALUE 24			VALUE 21	VALUE 5
7		VALUE 8	VALUE 14		VALUE 25			VALUE 2	VALUE 6
8		VALUE 9	VALUE 15		VALUE 26			VALUE 5	VALUE 7
9			VALUE 16		VALUE 27			VALUE 11	VALUE 8
10			VALUE 17		VALUE 28			VALUE 19	VALUE 9
11					VALUE 29			VALUE 22	VALUE 10
12					VALUE 30			VALUE 3	VALUE 11
13					VALUE 31			VALUE 6	VALUE 12
14								VALUE 12	VALUE 13
15								VALUE 20	VALUE 14
16								VALUE 23	VALUE 15
17								VALUE 7	VALUE 16
18								VALUE 13	VALUE 17
19								VALUE 24	VALUE 18
20								VALUE 8	VALUE 19
21								VALUE 14	VALUE 20
22								VALUE 25	VALUE 21
23								VALUE 9	VALUE 22
24								VALUE 15	VALUE 23
25								VALUE 26	VALUE 24
26								VALUE 16	VALUE 25
27								VALUE 27	VALUE 26
28								VALUE 17	VALUE 27
29								VALUE 28	VALUE 28
30								VALUE 29	VALUE 29
31								VALUE 30	VALUE 30
32								VALUE 31	VALUE 31
33
Main

Cell Formulas
Range	Formula
H2:H32	H2	=LET(data,A3:E13,c,COLUMNS(data),s,SEQUENCE(c*ROWS(data),,0),x,INDEX(data,INT(s/c)+1,MOD(s,c)+1),FILTER(x,x<>""))
I2:I32	I2	=LET(data,A3:E13,r,ROWS(data),s,SEQUENCE(r*COLUMNS(data),,0),x,INDEX(data,MOD(s,r)+1,INT(s/r)+1),FILTER(x,x<>""))
Dynamic array formulas.

 

[Kra]

How about with a formula?
Two options, one does what your macro is doing & the other gives the data as you have shown it.

Fluff.xlsm
	A	B	C	D	E	F	G	H	I
1	Input:							Output:
2								VALUE 1	VALUE 1
3	VALUE 1	VALUE 4	VALUE 10	VALUE 18	VALUE 21			VALUE 4	VALUE 2
4	VALUE 2	VALUE 5	VALUE 11	VALUE 19	VALUE 22			VALUE 10	VALUE 3
5	VALUE 3	VALUE 6	VALUE 12	VALUE 20	VALUE 23			VALUE 18	VALUE 4
6		VALUE 7	VALUE 13		VALUE 24			VALUE 21	VALUE 5
7		VALUE 8	VALUE 14		VALUE 25			VALUE 2	VALUE 6
8		VALUE 9	VALUE 15		VALUE 26			VALUE 5	VALUE 7
9			VALUE 16		VALUE 27			VALUE 11	VALUE 8
10			VALUE 17		VALUE 28			VALUE 19	VALUE 9
11					VALUE 29			VALUE 22	VALUE 10
12					VALUE 30			VALUE 3	VALUE 11
13					VALUE 31			VALUE 6	VALUE 12
14								VALUE 12	VALUE 13
15								VALUE 20	VALUE 14
16								VALUE 23	VALUE 15
17								VALUE 7	VALUE 16
18								VALUE 13	VALUE 17
19								VALUE 24	VALUE 18
20								VALUE 8	VALUE 19
21								VALUE 14	VALUE 20
22								VALUE 25	VALUE 21
23								VALUE 9	VALUE 22
24								VALUE 15	VALUE 23
25								VALUE 26	VALUE 24
26								VALUE 16	VALUE 25
27								VALUE 27	VALUE 26
28								VALUE 17	VALUE 27
29								VALUE 28	VALUE 28
30								VALUE 29	VALUE 29
31								VALUE 30	VALUE 30
32								VALUE 31	VALUE 31
33
Main

Cell Formulas
Range	Formula
H2:H32	H2	=LET(data,A3:E13,c,COLUMNS(data),s,SEQUENCE(c*ROWS(data),,0),x,INDEX(data,INT(s/c)+1,MOD(s,c)+1),FILTER(x,x<>""))
I2:I32	I2	=LET(data,A3:E13,r,ROWS(data),s,SEQUENCE(r*COLUMNS(data),,0),x,INDEX(data,MOD(s,r)+1,INT(s/r)+1),FILTER(x,x<>""))
Dynamic array formulas.

I am not able to use formulas sadly, because this sheet will be used by many people and they will place data in random places. Is it possible to add this kind of sorting into a code?

 

[Kra]

You can just add additional code to your code that selects the range you pasted to, and select the blank cells, then deletes them, shifting everything else up, like this:

Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim lr As Long
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False

'Find last row in column of Range2 with data
lr = Cells(Rows.Count, Range2.Column).End(xlUp).Row
'Remove all blanks from final paste range
Range(Cells(Range2.Row, Range2.Column), Cells(lr, Range2.Column)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp

Application.ScreenUpdating = True
End Sub

Works amazing, thanks! Is it possible to take this data sorted? Or it is too much to ask?

 

[Joe4]

If you want to sort the data, then there is no reason for us to delete the blanks, because sorting will move them to the bottom automatically.
So we can replace the "Delete" code with some "Sort" code like this:

Sub ConvertRangeToColumn()

Dim Range1 As Range, Range2 As Range, Rng As Range, Range3 As Range
Dim lr As Long
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False

'Find last row in column of Range2 with data
lr = Cells(Rows.Count, Range2.Column).End(xlUp).Row
'Set range to sort
Set Range3 = Range(Cells(Range2.Row, Range2.Column), Cells(lr, Range2.Column))
'Sort range
Range3.Sort Key1:=Range2, Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom
        
Application.ScreenUpdating = True

End Sub

 

[Kra]

If you want to sort the data, then there is no reason for us to delete the blanks, because sorting will move them to the bottom automatically.
So we can replace the "Delete" code with some "Sort" code like this:

Sub ConvertRangeToColumn()

Dim Range1 As Range, Range2 As Range, Rng As Range, Range3 As Range
Dim lr As Long
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False

'Find last row in column of Range2 with data
lr = Cells(Rows.Count, Range2.Column).End(xlUp).Row
'Set range to sort
Set Range3 = Range(Cells(Range2.Row, Range2.Column), Cells(lr, Range2.Column))
'Sort range
Range3.Sort Key1:=Range2, Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom
       
Application.ScreenUpdating = True

End Sub

Now it is sorting in an odd way. As you can see in column A there are values starting with "9TF". After running a macro (results in column L) first 9TF in on the top of the list and second on the bottom.

Test.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1												9TF000138
2												9B0001940
3												9B0002071
4												9B0002102
5												9B0002218
6												9D0003126
7												9D0003127
8												9D0003376
9												9D0003434
10	9TF000138	9B0002102	9D0003376	9K0008633								9D0003577
11	9TF000281	9B0001940	9D0003434	9K0008634								9D0003578
12		9B0002218	9D0003126	9K0008635								9K0007648
13		9B0002071	9D0003127	9K0008856								9K0007649
14			9D0003577	9K0008857								9K0007650
15			9D0003578	9K0007648								9K0007651
16				9K0007649								9K0007652
17				9K0007650								9K0007653
18				9K0007651								9K0008175
19				9K0007652								9K0008633
20				9K0007653								9K0008634
21				9K0008175								9K0008635
22				9K0009334								9K0008856
23				9K0009335								9K0008857
24				9K0009336								9K0009334
25				9K0009337								9K0009335
26				9K0009338								9K0009336
27				9K0009339								9K0009337
28				9K0009340								9K0009338
29				9K0009341								9K0009339
30				9K0009342								9K0009340
31				9K0009343								9K0009341
32												9K0009342
33												9K0009343
34												9TF000281
35
X

 

[Joe4]

Whoops, had a bad setting.

This part of the code:

Header:=xlYes

should actually be this:

Header:=xlNo

So the final code would look like:

Sub ConvertRangeToColumn()

Dim Range1 As Range, Range2 As Range, Rng As Range, Range3 As Range
Dim lr As Long
Dim rowIndex As Integer
xTitleId = "Move to one column"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False

'Find last row in column of Range2 with data
lr = Cells(Rows.Count, Range2.Column).End(xlUp).Row
'Set range to sort
Set Range3 = Range(Cells(Range2.Row, Range2.Column), Cells(lr, Range2.Column))
'Sort range
Range3.Sort Key1:=Range2, Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom
        
Application.ScreenUpdating = True

End Sub