2
\$\begingroup\$

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
\$\endgroup\$
  • \$\begingroup\$ You shouldn't convert the date value into a text value. It is better to format the columns after you write the data back to the spreadsheet. \$\endgroup\$ – user109261 Feb 10 '18 at 20:13
  • \$\begingroup\$ I am sometimes getting US formats written out to the sheet if I don't do that. I can't format the column after to be UK as it won't always know which should be converted. I would have to assume they are always US and re-arrange the characters in the sheet? A UK format goes into the array, but when transferring between arrays it seems US format kicks in and goes back out to sheet. This doesn't always happen which is weird. Tbh I edited that change in because I suddenly noticed the change. Happy to have advice on how to resolve. It is a pain i usually get around by simply working with strings. \$\endgroup\$ – QHarr Feb 10 '18 at 20:20
  • \$\begingroup\$ You should be able to apply the "yyyy-mm-dd" format to the columns regardless of the Excel version Columns("A").NumberFormat = "yyyy-mm-dd". \$\endgroup\$ – user109261 Feb 12 '18 at 1:53
  • \$\begingroup\$ @ThomasInzina What I am saying is if during the array to array transition #12/02/2018# has become #02/12/2018# how will formatting the sheet with "yyyy-mm-dd" ensure I will have the original #12/02/2018# back as #02/12/2018# would also be recognised as valid. Apologies if I am being more dense than usual on this. \$\endgroup\$ – QHarr Feb 12 '18 at 9:19
  • \$\begingroup\$ I didn't think that you would run into the dd/mm/yyyy issue. You could try using.Range("A1:K2").Value2 and tempArr2(i, 1) = tempArr(i, 9). .Value2 ignores formatting and uses the integer value of the Date. Of course, you will still have to change the Columns format. It would probably be easier to do it your way. \$\endgroup\$ – user109261 Feb 12 '18 at 9:38
1
\$\begingroup\$

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:

OP Code

Test results with this code:

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.

| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ The OP's code works because he is using two complete arrays. By swapping columns individually, you are not putting the data in the right order. When i = 0 Column 9 is swapped with Column 1. Then when i = 5 Column 1 (which is the data from Column 9) is swapped with Column 6. \$\endgroup\$ – user109261 Feb 12 '18 at 8:59
  • \$\begingroup\$ @ThomasInzina this type of question is about the only good argument I have for Option Base 1, which I still can't bring myself to use. \$\endgroup\$ – Raystafarian Feb 12 '18 at 22:42
  • \$\begingroup\$ @PaulBica I will been running these tomorrow and feedback. Many thanks for your time. \$\endgroup\$ – QHarr Feb 12 '18 at 22:44
  • \$\begingroup\$ Very quick solution. Much obliged. \$\endgroup\$ – QHarr Feb 14 '18 at 14:08
  • \$\begingroup\$ What was this line for fc = fc - 1 'Optimized for the loop please? \$\endgroup\$ – QHarr Feb 14 '18 at 14:12
1
\$\begingroup\$

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
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ I like the using an Array to store the column numbers. isRow doesn't sound right to me. Consider borrow a parameter from Range.Find method and writing it like this: Private Function GetLast(ByVal targetSheet As Worksheet, ByVal SearchOrder As XlSearchOrder) As Long \$\endgroup\$ – user109261 Feb 12 '18 at 9:11
  • \$\begingroup\$ This sounds very interesting..... I guess my question is, is this better because you are pulling out the column mapping so this becomes more versatile? One simply adjusts the Const for the column mappings presumably with some check that the in columns are +1 to the out. Speed wise I guess little difference. \$\endgroup\$ – QHarr Feb 12 '18 at 9:21
  • \$\begingroup\$ @ThomasInzina I couldn't think of anything better than isRow - ha. You know how sometimes you're focused and working through something then lose your train of thought and you look back and don't understand exactly what you're trying to do? Yeah. \$\endgroup\$ – Raystafarian Feb 12 '18 at 22:37
  • \$\begingroup\$ @QHarr I wouldn't say this is better. I think yes by pulling out your mapping it's easier to adjust it if anything changes, same goes for all constants, just change it once and it reflects it everywhere. Like I said, putting the data in an array and working off the array is the main thing, and you're doing that already! I do think it's better to avoid the list of all the mappings, that could get unwieldy as you increase the size of your array. Redimensioning your array with 1 to x, I agree, is easier to follow, so I can't say my arrays are better. \$\endgroup\$ – Raystafarian Feb 12 '18 at 22:40
  • 1
    \$\begingroup\$ In the many subs and functions in my project I have existing funcs for this. I enjoyed your ingredients project btw! \$\endgroup\$ – QHarr Feb 12 '18 at 22:46

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.