Reorder columns in Array

Question

I am reordering columns in an array and removing one column. The mapping is as follows:

| Item   | In index | Out Index |
|--------|----------|-----------|
| Item1  | 1        | 6         |
| Item2  | 2        | 4         |
| Item3  | 3        | 5         |
| Item4  | 4        | 7         |
| Item5  | 5        | 8         |
| Item6  | 6        | 9         |
| Item7  | 7        | 10        |
| Item8  | 8        | #N/A      |
| Item9  | 9        | 1         |
| Item10 | 10       | 2         |
| Item11 | 11       | 3         |

So, with the following data in range A1:K2 of the active sheet:

| Category 1 | RX9 | East Midlands | 4588 | 14:47:36 | 00:08:25 | 00:14:52 |   | 01/10/17 | 09/02/18 | England |
|------------|-----|---------------|------|----------|----------|----------|---|----------|----------|---------|
| Category 1 | RX9 | East Midlands | 4588 | 14:47:36 | 00:08:25 | 00:14:52 |   | 01/10/17 | 09/02/18 | England |

I get, after running the code:

| 01/10/17 | 09/02/18 06:09 | England | RX9 | East Midlands | Category 1 | 4588 | 0.616388889 | 0.005844907 | 0.010324074 |
|----------|----------------|---------|-----|---------------|------------|------|-------------|-------------|-------------|
| 01/10/17 | 09/02/18 06:09 | England | RX9 | East Midlands | Category 1 | 4588 | 0.616388889 | 0.005844907 | 0.010324074 |

Notes:

1. I don't expect the array number of rows to ever exceed 12,240.

2. The time columns have become doubles in the output. Sorted with code to format the relevant columns - not pertinent to question.

Is there a more efficient way to do this without making arrays left, right and centre?

Option Explicit
Public Const OutputColumnsTotal As Long = 10

Private Sub test()

    Dim tempArr() As Variant

    With ActiveSheet

        tempArr = .Range("A1:K2").Value
        tempArr = ShuffleArrayColumns(tempArr)

        .Range("A5").Resize(UBound(tempArr, 1), UBound(tempArr, 2)) = tempArr

    End With

End Sub

Private Function ShuffleArrayColumns(ByRef tempArr As Variant) As Variant

    If Not UBound(tempArr, 2) - 1 = OutputColumnsTotal Then

        Debug.Print "Array tempArr as wrong # columns in " & Application.VBE.Activecodepane.CodeModule
        Exit Function

    Else

        Dim i As Long
        Dim tempArr2() As Variant
        ReDim tempArr2(1 To UBound(tempArr, 1), 1 To OutputColumnsTotal)

        For i = LBound(tempArr, 1) To UBound(tempArr, 1)

            tempArr2(i, 1) = Format$(tempArr(i, 9),"yyyy-mm-dd") 'to preserve UK date format. Sheet is formatted to display "mmm-yy".
            tempArr2(i, 2) = tempArr(i, 10)
            tempArr2(i, 3) = tempArr(i, 11)
            tempArr2(i, 4) = tempArr(i, 2)
            tempArr2(i, 5) = tempArr(i, 3)
            tempArr2(i, 6) = tempArr(i, 1)
            tempArr2(i, 7) = tempArr(i, 4)
            tempArr2(i, 8) = tempArr(i, 5)
            tempArr2(i, 9) = tempArr(i, 6)
            tempArr2(i, 10) = tempArr(i, 7)

        Next i

    End If

    ShuffleArrayColumns = tempArr2

End Function

Answer 1

Another approach is to work with individual columns:

Option Explicit

Public Sub ShuffleColumns()

    Const ROW_OFFSET As Long = 3

    Dim fr As Long, fc As Long, lr As Long, frx As Long, lrx As Long
    Dim res As Variant, arr As Variant, i As Long

    With Sheet1

        fr = .UsedRange.Row
        fc = .UsedRange.Column
        lr = .Cells(fr, fc).End(xlDown).Row

        frx = lr + ROW_OFFSET   'Next first row
        lrx = (frx - fr) + lr   'Next last row

        res = Array(9, 10, 11, 2, 3, 1, 4, 5, 6, 7) 'IN columns mapped to OUT columns

        fc = fc - 1 'Optimized for the loop

        For i = LBound(res) To UBound(res)

            arr = .Range(.Cells(fr, res(i) + fc), .Cells(lr, res(i) + fc))  'IN column

           .Range(.Cells(frx, i + 1 + fc), .Cells(lrx, i + 1 + fc)) = arr   'OUT column

        Next

       .Range(.Cells(frx, fc + 1), .Cells(lrx, fc + 1)).NumberFormat = "yyyy-mm-dd"

    End With
End Sub

.

Note: Public Const OutputColumnsTotal As Long = 10 is global but it is used only in ShuffleArrayColumns() - it's advisable to declare constants and vars as close to their scope as possible

.

Test results with OP code:

Test results with this code:

Performance: for 100,000 rows - 2.167 sec (OP code) vs 1.277 sec (this code)

---

Edit

Testing with different optimizations for the FOR loop:

Version 2

Public Sub ShuffleColumnsUnoptimizedFC()
    Const ROW_OFFSET As Long = 3

    Dim fr As Long, fc As Long, lr As Long, frx As Long, lrx As Long
    Dim res As Variant, arr As Variant, i As Long, t As Double
    With Sheet1
        t = Timer
        fr = .UsedRange.Row
        fc = .UsedRange.Column
        lr = .Cells(fr, fc).End(xlDown).Row

        frx = lr + ROW_OFFSET
        lrx = (frx - fr) + lr

        res = Array(9, 10, 11, 2, 3, 1, 4, 5, 6, 7)
        For i = LBound(res) To UBound(res)
            arr = .Range(.Cells(fr, res(i) + fc - 1), .Cells(lr, res(i) + fc - 1))
           .Range(.Cells(frx, i + 1 + fc - 1), .Cells(lrx, i + 1 + fc - 1)) = arr
        Next
       .Range(.Cells(frx, fc), .Cells(lrx, fc)).NumberFormat = "yyyy-mm-dd"
        Debug.Print "Rows: " & lr & "; Time: " & Format("0.000", Timer - t) & " sec"
    End With
End Sub

---

Version 3

Public Sub ShuffleColumnsUnoptimizedLoop()
    Const ROW_OFFSET As Long = 3

    Dim fr As Long, fc As Long, lr As Long, frx As Long, lrx As Long
    Dim res As Variant, arr As Variant, i As Long, t As Double
    With Sheet1
        t = Timer
        fr = .UsedRange.Row
        fc = .UsedRange.Column
        lr = .Cells(fr, fc).End(xlDown).Row

        frx = lr + ROW_OFFSET
        lrx = (frx - fr) + lr

        res = Array(9, 10, 11, 2, 3, 1, 4, 5, 6, 7)
        For i = LBound(res) To UBound(res)
            arr = .Range(.Cells(fr, res(i) + fc - 1), .Cells(lr, res(i) + fc - 1))
           .Range(.Cells(frx, i + 1 + fc - 1), .Cells(lrx, i + 1 + fc - 1)) = arr
            If i = 1 Then
                .Range(.Cells(frx, fc), .Cells(lrx, fc)).NumberFormat = "yyyy-mm-dd"
            End If
        Next
        Debug.Print "Rows: " & lr & "; Time: " & Format("0.000", Timer - t) & " sec"
    End With
End Sub

After 3 tests with 500,000 rows

Rows: 500,000; Time: 7.01171875 sec (v1)
Rows: 500,000; Time: 7.05078125 sec (v2)
Rows: 500,000; Time: 7.08984375 sec (v3)

---

The idea is to move all unnecessary operations outside the loop - repetition will amplify any minor effort - exponentially if the loops are nested.

Answer 2

In my opinion, you aren't too far off with your approach unless you could remap entire arrays without a loop, which as far as I know, you can't. You've done a good thing, bringing everything into an array before using it, instead of miffing around with the sheet. Props to that.

You could use some more constants, and you could shuffle your columns with a loop instead of a list of -

tempArr2(i, 2) = tempArr(i, 10)
tempArr2(i, 3) = tempArr(i, 11)
tempArr2(i, 4) = tempArr(i, 2)
tempArr2(i, 5) = tempArr(i, 3)
tempArr2(i, 6) = tempArr(i, 1)
etc

Something like this, but it would probably need some refactoring. Also, more descriptive variable names will make it easier to follow -

Public Sub ArrayShuffle()
    Const NUMBER_OF_COLUMNS As Long = 9
    Const OLD_COLUMNS As String = "9,10,11,2,3,1,4,5,6,7"
    Dim oldColumnArray As Variant
    oldColumnArray = Split(OLD_COLUMNS, ",")
    Dim oldColumn(NUMBER_OF_COLUMNS) As Long
    Dim arrayIndex As Long
    For arrayIndex = LBound(oldColumnArray) To UBound(oldColumnArray)
        oldColumn(arrayIndex) = CInt(oldColumnArray(arrayIndex))
    Next

    Dim lastRow As Long
    lastRow = GetLast(Sheet1, True)
    Dim lastColumn As Long
    lastColumn = GetLast(Sheet1, False)

    Dim rowIndex As Long
    Dim columnIndex As Long

    Dim inputArray As Variant
    inputArray = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(lastRow, lastColumn))
    Dim newArray As Variant
    ReDim newArray(UBound(inputArray, 1) - 1, NUMBER_OF_COLUMNS)

    For arrayIndex = LBound(inputArray, 2) To UBound(inputArray, 2)
        For rowIndex = 1 To lastRow
            For columnIndex = 1 To NUMBER_OF_COLUMNS + 1
                newArray(rowIndex - 1, columnIndex - 1) = inputArray(rowIndex - 1, oldColumn(columnIndex - 1))
            Next
        Next
    Next


End Sub

Private Function GetLast(ByVal targetSheet As Worksheet, ByVal isRow As Boolean) As Long
    If isRow Then
        GetLast = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        GetLast = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    End If
End Function