trjhtr

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

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.

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