Moving data between two sheets VBA

**paulked** · 04-19-2020, 11:37 AM

I had a moment to review my code from yesterday and found that if you had 10 loans over 12 months the code would take 2.38 seconds to complete. The more loan repayments, the longer it takes! 10 loans over 24 months = 5secs +

So I've made the code much faster and 10 loans over 24 months takes just 0.25secs to complete. This, obviously, only matters if you have a lot of loans over longer periods, that I don't know. But I do know that I'm still learning VBA and wasn't happy with my earlier code, even if it did work!

New code:

Sub MoveData2()
    Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet, ar() As Variant
    Application.ScreenUpdating = False
    Set wsS = Sheets("From Here")
    Set wsD = Sheets("To Here")
    rw = wsD.Cells(Rows.Count, 1).End(xlUp).Row
    lr = wsS.Cells(Rows.Count, 1).End(xlUp).Row
    wsD.Range("A2:J" & rw + 1).ClearContents
    rw = 1
    ReDim Preserve ar(10, rw)
    For i = 2 To lr
        With wsD
            ReDim Preserve ar(10, rw)
            ar(1, rw) = wsS.Cells(i, 1) 'Ref
            ar(2, rw) = "ABC1"
            ar(3, rw) = "GBP"
            ar(4, rw) = wsS.Cells(i, 9) 'Date
            ar(5, rw) = "Loan"
            ar(6, rw) = wsS.Cells(i, 6) 'Value
            ar(7, rw) = "Loan"
            ar(8, rw) = "123"
            ar(9, rw) = wsS.Cells(i, 4) 'Practice Ref
            ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
            rw = rw + 1
            For j = 1 To wsS.Cells(i, 7)
                ReDim Preserve ar(10, rw)
                ar(1, rw) = wsS.Cells(i, 1)
                ar(2, rw) = ar(2, rw - 1)
                ar(3, rw) = ar(3, rw - 1)
                If j = 1 Then ar(4, rw) = wsS.Cells(i, 9) 'Date
                If j <> 1 Then ar(4, rw) = Application.WorksheetFunction.EoMonth(DateAdd("m", 1, ar(4, rw - 1)), 0) 'Date
                ar(5, rw) = wsS.Cells(i, 4) & "-Instalment " & j
                ar(6, rw) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
                ar(7, rw) = "Instal " & j
                ar(8, rw) = ar(8, rw - 1)
                ar(9, rw) = wsS.Cells(i, 4)
                ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
                rw = rw + 1
            Next
        End With
    Next
    Sheet2.Range("A2:J" & rw) = WorksheetFunction.Transpose(ar)
End Sub

**p45cal** · 04-19-2020, 02:38 PM

paulked, I've been caught out by Transpose in the past, it can mangle your data. It changes variables of Date type to strings. When those strings are written to the sheet, you're dependent on Excel correctly interpreting those strings back into dates - and that's dependent on locale.
Ideally you'd populate the array in the right orientation from the start but Redim Preserve only being allowed to change the last dimension of the array precludes that. If you want to be robust, you can instead transpose the array in nested For loops (it doesn't take long (it may even be faster than Transpose!)).

Before WorksheetFunction.Transposition:
2020-04-19_221253.jpg

After:
2020-04-19_221823.jpg

Incidentally, I noticed in the upper picture that that column had a mixture of Doubles and Dates; you'd think that WorksheetFunction.EoMonth in conjunction with DateAdd would produce a Date type value - seems no such luck. So you could CDate that calculation but perhaps you could have ALL the dates as Longs or Doubles (CLng(wsS.Cells(i, 9))) and simply format that column of cells as dates at the end of your macro - that way you wouldn't need to worry about Transpose! Sigh, I've just gone round in a circle.

**paulked** · 04-19-2020, 02:49 PM

Very useful information, thank you.

Yes, I struggled with the array to begin with... until I read about redimming the last element only!

I like the suggestion of the dates as long (or double if time is included), and transposing in loops.

Again, thanks for the info, it has been taken on board for next time

**paulked** · 04-19-2020, 03:36 PM

3rd time lucky?

Sub MoveData3()
    Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet, ar() As Variant
    Application.ScreenUpdating = False
    Set wsS = Sheets("From Here")
    Set wsD = Sheets("To Here")
    rw = wsD.Cells(Rows.Count, 1).End(xlUp).Row
    lr = wsS.Cells(Rows.Count, 1).End(xlUp).Row
    wsD.Range("A2:J" & rw + 1).ClearContents
    rw = 1
    ReDim Preserve ar(10, rw)
    For i = 2 To lr
        With wsD
            ReDim Preserve ar(10, rw)
            ar(1, rw) = wsS.Cells(i, 1) 'Ref
            ar(2, rw) = "ABC1"
            ar(3, rw) = "GBP"
            ar(4, rw) = CLng(wsS.Cells(i, 9)) 'Date
            ar(5, rw) = "Loan"
            ar(6, rw) = wsS.Cells(i, 6) 'Value
            ar(7, rw) = "Loan"
            ar(8, rw) = "123"
            ar(9, rw) = wsS.Cells(i, 4) 'Practice Ref
            ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
            rw = rw + 1
            For j = 1 To wsS.Cells(i, 7)
                ReDim Preserve ar(10, rw)
                ar(1, rw) = wsS.Cells(i, 1)
                ar(2, rw) = ar(2, rw - 1)
                ar(3, rw) = ar(3, rw - 1)
                If j = 1 Then ar(4, rw) = CLng(wsS.Cells(i, 9)) 'Date
                If j <> 1 Then ar(4, rw) = CLng(Application.WorksheetFunction.EoMonth(DateAdd("m", 1, ar(4, rw - 1)), 0)) 'Date
                ar(5, rw) = wsS.Cells(i, 4) & "-Instalment " & j
                ar(6, rw) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
                ar(7, rw) = "Instal " & j
                ar(8, rw) = ar(8, rw - 1)
                ar(9, rw) = wsS.Cells(i, 4)
                ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
                rw = rw + 1
            Next
        End With
    Next
    Sheet2.Range("A2:J" & rw) = Tx2DArr(ar)
End Sub

Function Tx2DArr(inputArray As Variant) As Variant
    Dim x As Long, yUbound As Long, y As Long, xUbound As Long, tempArray As Variant
    xUbound = UBound(inputArray, 2)
    yUbound = UBound(inputArray, 1)
    ReDim tempArray(1 To xUbound, 1 To yUbound)
    For x = 1 To xUbound
        For y = 1 To yUbound
            tempArray(x, y) = inputArray(y, x)
        Next y
    Next x
    Tx2DArr = tempArray
End Function

I tried it with 20 loans of 48 months (980 rows of output) and the results before and after were very similar.
67172.jpg

Thanks Pascal

PS Thanks www.excelcise.org for the transpose code.

**TheWennerWom** · 04-21-2020, 10:16 AM

Originally Posted by paulked

3rd time lucky?

Sub MoveData3()
    Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet, ar() As Variant
    Application.ScreenUpdating = False
    Set wsS = Sheets("From Here")
    Set wsD = Sheets("To Here")
    rw = wsD.Cells(Rows.Count, 1).End(xlUp).Row
    lr = wsS.Cells(Rows.Count, 1).End(xlUp).Row
    wsD.Range("A2:J" & rw + 1).ClearContents
    rw = 1
    ReDim Preserve ar(10, rw)
    For i = 2 To lr
        With wsD
            ReDim Preserve ar(10, rw)
            ar(1, rw) = wsS.Cells(i, 1) 'Ref
            ar(2, rw) = "ABC1"
            ar(3, rw) = "GBP"
            ar(4, rw) = CLng(wsS.Cells(i, 9)) 'Date
            ar(5, rw) = "Loan"
            ar(6, rw) = wsS.Cells(i, 6) 'Value
            ar(7, rw) = "Loan"
            ar(8, rw) = "123"
            ar(9, rw) = wsS.Cells(i, 4) 'Practice Ref
            ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
            rw = rw + 1
            For j = 1 To wsS.Cells(i, 7)
                ReDim Preserve ar(10, rw)
                ar(1, rw) = wsS.Cells(i, 1)
                ar(2, rw) = ar(2, rw - 1)
                ar(3, rw) = ar(3, rw - 1)
                If j = 1 Then ar(4, rw) = CLng(wsS.Cells(i, 9)) 'Date
                If j <> 1 Then ar(4, rw) = CLng(Application.WorksheetFunction.EoMonth(DateAdd("m", 1, ar(4, rw - 1)), 0)) 'Date
                ar(5, rw) = wsS.Cells(i, 4) & "-Instalment " & j
                ar(6, rw) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
                ar(7, rw) = "Instal " & j
                ar(8, rw) = ar(8, rw - 1)
                ar(9, rw) = wsS.Cells(i, 4)
                ar(10, rw) = "P" & Right(wsS.Cells(i, 1), 5)
                rw = rw + 1
            Next
        End With
    Next
    Sheet2.Range("A2:J" & rw) = Tx2DArr(ar)
End Sub

Function Tx2DArr(inputArray As Variant) As Variant
    Dim x As Long, yUbound As Long, y As Long, xUbound As Long, tempArray As Variant
    xUbound = UBound(inputArray, 2)
    yUbound = UBound(inputArray, 1)
    ReDim tempArray(1 To xUbound, 1 To yUbound)
    For x = 1 To xUbound
        For y = 1 To yUbound
            tempArray(x, y) = inputArray(y, x)
        Next y
    Next x
    Tx2DArr = tempArray
End Function

I tried it with 20 loans of 48 months (980 rows of output) and the results before and after were very similar.

Thanks for your efforts all.

Apparently, from having asked at work, this bit of business is going to affect 2,500 loans, all over 10 months, so a lot of records!!

**paulked** · 04-21-2020, 10:32 AM

Wow!

The code can cope... just did 2500 loans at 10 months in 30.12 seconds (27,500 lines) Pretty good

**paulked** · 04-21-2020, 10:35 AM

aside: snb pops in and does it in under two seconds with three lines of code

Thread: Moving data between two sheets VBA

Thread Tools

Display

Tags for this Thread

Posting Permissions