HiveBrain v1.2.0
Get Started
← Back to all entries
patternMinor

Rearrange data without using Cut and Insert

Submitted by: @import:stackexchange-codereview··
0
Viewed 0 times
withoutrearrangeinsertcutusinganddata

Problem

I'm fairly new to VBA, and this was basically a brute-force solution to a problem I was encountering. I wanted to take data that appeared in two columns, and pull it together into one.

The current code works, but is very slow with large datasets. I've been told to avoid using the clipboard if possible, but I'm not quite sure where to begin with this. I've made a few attempts to use an array, but I'm not quite sure where to start. Any other suggestions would be very welcome.

Private Sub Arra()

    Dim Library As Worksheet
    Set Library = Sheets("Library")
    Dim Rng As Range
    Dim i As Long
    Dim lastRow As Long
    i = 1
    lastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).row

    While i <= lastRow
    Set Rng = Library.Range("A" & i)
         If Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 1 Then
             Rng.Offset(0, 1).Cut
             Rng.Offset(1, 0).Insert Shift:=xlDown
             Rng.Offset(0, 1).Insert Shift:=xlDown
        ElseIf Application.WorksheetFunction.CountA(Rng.Offset(0, 1)) = 0 Then
            i = i + 1
        End If
    Wend

End Sub

Solution

To speed it up, I would read it into arrays. One array for column A and one array for column B and then combine them into another array and print that to sheet

Option Explicit
Sub Rearrange()
    Dim lastRow As Long
    lastRow = Library.Cells(Rows.Count, 1).End(xlUp).Row
    Dim firstColumn As Variant
    firstColumn = Library.Range("A1:A" & lastRow)
    Dim secondColumn As Variant
    secondColumn = Library.Range("B1:B" & lastRow)
    Dim totalCount As Long
    totalCount = Application.CountA(firstColumn) + Application.CountA(secondColumn)

    Dim combinedArray As Variant
    ReDim combinedArray(1 To totalCount)
    Dim i As Long
    Dim index As Long
    index = 1

    For i = 1 To lastRow
        combinedArray(index) = firstColumn(i, 1)
        index = index + 1
        If Not IsEmpty(secondColumn(i, 1)) Then
            combinedArray(index) = secondColumn(i, 1)
            index = index + 1
        End If
    Next

    Library.Range("A1:A" & totalCount) = Application.Transpose(combinedArray)

End Sub


Arrays are fast!

Also, as you can see worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("Library") and instead just use Library.

I also switched your

lastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).row


To the standard.

I also used a For loop instead of Do While.

Code Snippets

Option Explicit
Sub Rearrange()
    Dim lastRow As Long
    lastRow = Library.Cells(Rows.Count, 1).End(xlUp).Row
    Dim firstColumn As Variant
    firstColumn = Library.Range("A1:A" & lastRow)
    Dim secondColumn As Variant
    secondColumn = Library.Range("B1:B" & lastRow)
    Dim totalCount As Long
    totalCount = Application.CountA(firstColumn) + Application.CountA(secondColumn)

    Dim combinedArray As Variant
    ReDim combinedArray(1 To totalCount)
    Dim i As Long
    Dim index As Long
    index = 1

    For i = 1 To lastRow
        combinedArray(index) = firstColumn(i, 1)
        index = index + 1
        If Not IsEmpty(secondColumn(i, 1)) Then
            combinedArray(index) = secondColumn(i, 1)
            index = index + 1
        End If
    Next

    Library.Range("A1:A" & totalCount) = Application.Transpose(combinedArray)

End Sub
lastRow = Library.Range("A1").SpecialCells(xlCellTypeLastCell).row

Context

StackExchange Code Review Q#128582, answer score: 4

Revisions (0)

No revisions yet.