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