Converting a range in excel to a single column with excel vba

Question

I am very new to coding and know only the basics. The first part of this code is running fine. It converts a range of values to a single column. However, with my data set the rows of data step down, as shown in the sample data set below, so that when they are converted to a single column there are large gaps of 0 values in the column. I added a portion of code to the end to look at each cell in the column and delete any 0 values. The problem is this code takes around 4-5 hours to run. I am hoping there is a better way to write the code to speed up the processing time.

Any help is appreciated!

Sub CombineColumns() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim rng As Range Dim iCol As Long Dim lastCell As Long Dim k As Long k = 484 'set K equal to the number of data points that created the range Set rng = ActiveCell.CurrentRegion lastCell = rng.Columns(1).Rows.Count + 1 For iCol = 2 To rng.Columns.Count Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)).Cut ActiveSheet.Paste Destination:=Cells(lastCell, 1) lastCell = lastCell + rng.Columns(iCol).Rows.Count Next iCol Dim z As Long Dim m As Long z = k ^ 2 For row = z To 1 Step -1 If Cells(row, 1) = 0 Then Range("A" & row).Delete Shift:=xlUp Application.StatusBar = "Progress: " & row & " of z: " & Format((z - row) / z, "Percent") DoEvents End If Next Application.StatusBar = False Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub 

Answer 1

4-5 hours is ridiculous

4-5 hours with ScreenUpdating, Events, & Calculation disabled is even more so.

What you've discovered here is that Excel is very slow at inserting/deleting columns/rows when you have large amounts of data in a Worksheet.

and you're doing it up to 235,000 times.

---

Delete everything in a single operation

What we're going to do here is loop through Ranges and, as we go, add all the Ranges-to-be-deleted to one master Range using the Union() function.

Then, at the end, delete the entire master range in one go:

Dim rowsToBeDeleted As Range '/ our master delete range For row = Z To 1 Step -1 If Cells(row, 1) = 0 Then If rowsToBeDeleted is Nothing Then '/ check if any ranges have been added yet Set rowsToBeDeleted = Range("A" & row) '/ add the first range Else Set rowsToBeDeleted = Union(rowsToBeDeleted, Range("A" & row)) '/ add the new range to the existing ones End If End If Next row If Not rowsToBeDeleted Is Nothing Then '/ check that we found anything to delete rowsToBeDeleted.EntireRow.Delete End If 

I suspect that this change alone will take your runtime from hours to minutes.

(Just as an aside, worth noting that a Range object can only have up to 1,048,576 range areas. So if you ever get up to more than 1,024^2, you'll have to check against it.)

Answer 2

Consider an SQL solution using the UNION query of NOT NULL columns and avoid any loop, screen controls, or range references. To set up, simply give your columns names (Col1, Col2, Col3, ...) in a DATA worksheet, and an empty RESULTS worksheet. Do note this would only work for Excel for PC as it connects to the JET/ACE SQL Engine (Window .dll files) via ADO interface.

Dim conn As Object, rst As Object Dim strConnection As String, strSQL As String Dim i As Integer Set conn = CreateObject("ADODB.Connection") Set rst = CreateObject("ADODB.Recordset") ' TWO CONNECTION STRINGS ' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ ' & "DBQ=C:\Path\To\Workbook.xlsm;" strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ & "Data Source='C:\Path\To\Workbook.xlsm';" _ & "Extended Properties=""Excel 8.0;HDR=YES;"";" strSQL = " SELECT [DATA$].Col1 As SingleColumn FROM [DATA$] WHERE [DATA$].Col1 IS NOT NULL" _ & " UNION ALL SELECT [DATA$].Col2 FROM [DATA$] WHERE [DATA$].Col2 IS NOT NULL" _ & " UNION ALL SELECT [DATA$].Col3 FROM [DATA$] WHERE [DATA$].Col3 IS NOT NULL" _ ' ...add more columns... ' OPEN WORKBOOK CONNECTION conn.Open strConnection rst.Open strSQL, conn ' COLUMN HEADERS For i = 1 To rst.Fields.Count Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name Next i ' DATA ROWS Worksheets("RESULTS").Range("A2").CopyFromRecordset rst rst.Close: conn.Close Set rst = Nothing Set conn = Nothing 

Answer 3

"Copy(or Cut)&Paste" operations as well as "Deleting rows" ones are expensive operations in Excel UI.

And since "Cut row" means "Delete row", then "Cut&Paste" is a most expensive one!

So the best would be avoid both!

Let's see how to do that

---

Avoiding Copy(or Cut)&Paste

Since you're dealing with numbers, I assume your real concern is for their values, so you can bother .Value property of Range object only, rather then with cells fonts or backcolors (and all that jazz)

This means you can benefit from a very cheap statement like the following:

Range1.Value = Range2.Value 

where you only have to make sure that both ranges have the same size

in your case this could be coded as:

With Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)) Cells(lastCell, 1).Resize(.Rows.Count).Value = .Value End With 

thus leaving you with all those copied values to be deleted

for this task we can make use of the .ClearContent() method of Range object which, again, only deals with cell .Value property (as opposite to .Clear() method which is much more expensive since it deals with all Range object properties).

So that we could be tempted to just add a statement within our With block, which is just referring to the wanted (copied) range:

With Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)) Cells(lastCell, 1).Resize(.Rows.Count).Value = .Value .ClearContents End With 

Though syntactically correct, this approach isn't the fastest being that clearance made through many (as the columns are) statements

It's better to make a one-shot clearance:

With Cells(1,1).CurrentRegion ' 'loop code ' Intersect(.Cells.Offset(, 1), .Cells).ClearContents '<--| clear the copied cells End With 

where you clear the cells:

• belonging to the "original" CurrentRegion of Cell(1,1) since the With block keeps referring to the range as it was set at that moment, ignoring subsequent changes (all those pasted values down its first column)

• offsetted by 1

  to avoid first column of "original" CurrentRegion of Cell(1,1)

• intersecting with itself

  to avoid clearing columns out of the "original" CurrentRegion of Cell(1,1)

---

Avoid Deleting Rows

But the best is yet to come!

being your data structure as per your example you can avoid pasting blank values, and so having to delete them by the end as well

just limit the values-to-be-copied range down to its last non empty row, substituting:

With Range(Cells(1, iCol), Cells(rng.Columns(iCol).Rows.Count, iCol)) 

with:

With Range(Cells(1, iCol), Cells(Rows.Count, iCol).End(xlUp)) 

In fact

rng.Columns(iCol).Rows.Count

always refers to the same rows number, namely the rows number of rng, so that not always it could substituted with a constant but it doesn't account for the current column actual non-empty cells number

While:

Cells(Rows.Count, iCol).End(xlUp)

always follows the current column last non-empty cell

This way you won't have any blank cell copied into rng first column and therefore no rows to delete at all!

---

Use With keyword for full qualified range references

This is a golden rule for the following reasons:

1. avoids ranges misreferences

   coding:

   Worksheets("MySheetName").Cells(1, 1).CurrentRegion

   makes you sure to reference the CurrentRegion of Range "A1" of "MySheetName" worksheet

   while:

   Range(Cells(1, iCol), Cells(rng.Columns(iCol)) 

   actually has VBA refer to the active worksheet for all Range and Cells objects and to rng for Columns object.

   this could still be correct and easy to follow when the code is short enough and hasn't any Select/Selection and/or Activate/Active operations, nor opens any new workbook. Otherwise all those operations would soon lead to loose the active worksheet knowledge and range reference control

2. Speed up code

   since it avoids VBA te task to resolve a Range reference down to its root when unnecessary

---

Summary

all what above may result in the following "core"-code:

Sub CombineColumns() Dim iCol As Long With Worksheets("MySheetName").Cells(1, 1).CurrentRegion For iCol = 2 To .Columns.Count With .Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp)) .Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value End With Next iCol Intersect(.Cells.Offset(, 1), .Cells).ClearContents End With End Sub 

that you can combine with those application setting-on/offs (especially those about Calculation) and some user information like follows:

Sub CombineColumns() Dim iCol As Long TurnSettings False With Worksheets("MySheetName").Cells(1, 1).CurrentRegion For iCol = 2 To .Columns.Count Application.StatusBar = "Progress: " & iCol & " of: " & .Columns.Count & " (" & Format((.Columns.Count - iCol) / .Columns.Count, "Percent") & ")" With .Range(.Cells(1, iCol), .Cells(.Rows.Count, iCol).End(xlUp)) .Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value End With Next iCol Intersect(.Cells.Offset(, 1), .Cells).ClearContents End With TurnSettings True End Sub Sub TurnSettings(boolSetting As Boolean) With Application .StatusBar = Not boolSetting .ScreenUpdating = boolSetting .EnableEvents = boolSetting .Calculation = IIf(boolSetting, xlCalculationAutomatic, xlCalculationManual) End With End Sub