View Full Version : [SOLVED:] Moving data between two sheets VBA
TheWennerWom
04-17-2020, 11:46 PM
Hello,
I hope everyone is staying safe.
I am hoping that someone might be able to help, I will try to explain what I am attempting to achieve.
I have a sheet named "From Here". This sheet has nine columns and a sample dataset is as follows (top row is header) - there might be hundreds of records, I am listing just two:
Assoc Ref
Assoc Name
Practice
Practice Ref
Description
Amount
Repayment Months
Amount
1st Repayment
A34567
JOHN
TEST 1
PR100
PR100 Loan
3000
10
300
30/06/2020
A56789
JAMES
TEST 2
PR103
PR103 Loan
2000
2
1000
30/06/2020
I need to get this onto a sheet named "To Here" so that the output is like this (top row is header):
Assoc Ref
Company
Currency
Date
InvNo
Value
Description
Nominal
Practice Ref
El8 Code
A34567
ABC1
GBP
18/04/2020
Loan
3000
Loan
123
PR100
P34567
A34567
ABC1
GBP
30/06/2020
Instal 1
-300
Instal 1
123
PR100
P34567
A34567
ABC1
GBP
31/07/2020
Instal 2
-300
Instal 2
123
PR100
P34567
A34567
ABC1
GBP
31/08/2020
Instal 3
-300
Instal 3
123
PR100
P34567
A34567
ABC1
GBP
30/09/2020
Instal 4
-300
Instal 4
123
PR100
P34567
A34567
ABC1
GBP
31/10/2020
Instal 5
-300
Instal 5
123
PR100
P34567
A34567
ABC1
GBP
30/11/2020
Instal 6
-300
Instal 6
123
PR100
P34567
A34567
ABC1
GBP
31/12/2020
Instal 7
-300
Instal 7
123
PR100
P34567
A34567
ABC1
GBP
31/01/2021
Instal 8
-300
Instal 8
123
PR100
P34567
A34567
ABC1
GBP
28/02/2021
Instal 9
-300
Instal 9
123
PR100
P34567
A34567
ABC1
GBP
31/03/2021
Instal 10
-300
Instal 10
123
PR100
P34567
A56789
ABC1
GBP
18/04/2020
Loan
2000
Loan
123
PR103
P56789
A56789
ABC1
GBP
30/06/2020
Instal 1
-1000
Instal 1
123
PR103
P56789
A56789
ABC1
GBP
31/07/2020
Instal 2
-1000
Instal 2
123
PR103
P56789
On this sheet, Company, Currency and Nominal are constants, they never change. El8 Code is always "P" + the five digits from Assoc Ref.
Is this even remotely possible?
Thank you for reading.
paulked
04-18-2020, 04:56 AM
Hi and welcome to the forum.
Something like this?
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, wsS As Worksheet, wsD As Worksheet
Set wsS = Sheets("From Here")
Set wsD = Sheets("To Here")
rw = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1
lr = wsS.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
.Cells(rw, 4) = wsS.Cells(i, 9)
.Cells(rw, 5) = Null ' Invoice number - this could be input by the user
.Cells(rw, 6) = wsS.Cells(i, 6)
.Cells(rw, 7) = wsS.Cells(i, 5)
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 3)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
End With
Next
wsS.Range("A2:I" & lr).ClearContents
End Sub
TheWennerWom
04-18-2020, 05:38 AM
Hi and welcome to the forum.
Something like this?
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, wsS As Worksheet, wsD As Worksheet
Set wsS = Sheets("From Here")
Set wsD = Sheets("To Here")
rw = wsD.Cells(Rows.Count, 1).End(xlUp).Row + 1
lr = wsS.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
.Cells(rw, 4) = wsS.Cells(i, 9)
.Cells(rw, 5) = Null ' Invoice number - this could be input by the user
.Cells(rw, 6) = wsS.Cells(i, 6)
.Cells(rw, 7) = wsS.Cells(i, 5)
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 3)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
End With
Next
wsS.Range("A2:I" & lr).ClearContents
End Sub
Many thanks for that; it doesn't quite do what I need.
It moves the loan amounts from "From here" but doesn't then bring in the instalment amounts as per my table.
paulked
04-18-2020, 05:45 AM
You didn't ask for that.
Are they made up by dividing the Amount by the Repayment Months and putting that figure in Value column? Are they negative? Invoice number?
p45cal
04-18-2020, 05:49 AM
Make changes/additions to the table (called Table1) in the From Here sheet, go to the To Here sheet, right-click the table there and choose Refresh.
TheWennerWom
04-18-2020, 05:54 AM
You didn't ask for that.
Are they made up by dividing the Amount by the Repayment Months and putting that figure in Value column? Are they negative? Invoice number?
Apologies.
Yes, it's a straight division as a negative.......so £3,000 repaid over 10 months would see ten lines generated at £-300.
Invoice number is the practice number and the instalment number.......so it will be "PR1000-Instalment 1" etc
paulked
04-18-2020, 06:00 AM
Got it. Take a look at Pascals solution, that does that (he's psychic!)
TheWennerWom
04-18-2020, 06:00 AM
Make changes/additions to the table (called Table1) in the From Here sheet, go to the To Here sheet, right-click the table there and choose Refresh.
Many thanks for that, it's thrown up
26366
p45cal
04-18-2020, 06:41 AM
Many thanks for that, it's thrown upRight now, I don't know.
Does the file I attached refresh without an error before you make any changes?
Otherwise, attach the file which errors here, after removing unnecessary sheets (and desensitising it (but make sure the error's still thrown up)).
I'll have a dig around for what might be causing the error.
paulked
04-18-2020, 06:45 AM
Try this one:
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet
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).ClearContents
rw = 2
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1) 'Ref
.Cells(rw, 2) = "ABC1"
.Cells(rw, 3) = "GBP"
.Cells(rw, 4) = wsS.Cells(i, 9) 'Date
.Cells(rw, 5) = "Loan"
.Cells(rw, 6) = wsS.Cells(i, 6) 'Value
.Cells(rw, 7) = "Loan"
.Cells(rw, 8) = "123"
.Cells(rw, 9) = wsS.Cells(i, 4) 'Practice Ref
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
For j = 1 To wsS.Cells(i, 7)
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
If j = 1 Then .Cells(rw, 4) = wsS.Cells(i, 9) 'Date
If j <> 1 Then .Cells(rw, 4) = DateAdd("m", 1, .Cells(rw - 1, 4)) 'Date
.Cells(rw, 5) = "Instal " & j
.Cells(rw, 6) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
.Cells(rw, 7) = .Cells(rw, 5)
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 4)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
Next
End With
Next
End Sub
I'm not sure what to do with the Loan date or Practice (Test *), but those are easily changed.
paulked
04-18-2020, 06:58 AM
Updated code with end of month date for repayment, I'd missed it!
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet
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).ClearContents
rw = 2
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1) 'Ref
.Cells(rw, 2) = "ABC1"
.Cells(rw, 3) = "GBP"
.Cells(rw, 4) = wsS.Cells(i, 9) 'Date
.Cells(rw, 5) = "Loan"
.Cells(rw, 6) = wsS.Cells(i, 6) 'Value
.Cells(rw, 7) = "Loan"
.Cells(rw, 8) = "123"
.Cells(rw, 9) = wsS.Cells(i, 4) 'Practice Ref
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
For j = 1 To wsS.Cells(i, 7)
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
If j = 1 Then .Cells(rw, 4) = wsS.Cells(i, 9) 'Date
If j <> 1 Then .Cells(rw, 4) = Application.WorksheetFunction.EoMonth(DateAdd("m", 1, .Cells(rw - 1, 4)), 0) 'Date
.Cells(rw, 5) = "Instal " & j
.Cells(rw, 6) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
.Cells(rw, 7) = .Cells(rw, 5)
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 4)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
Next
End With
Next
End Sub
TheWennerWom
04-18-2020, 07:05 AM
No, it errors before I change anything. I'm using Office 2010, is that likely to be a factor?
TheWennerWom
04-18-2020, 07:08 AM
Updated code with end of month date for repayment, I'd missed it!
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet
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).ClearContents
rw = 2
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1) 'Ref
.Cells(rw, 2) = "ABC1"
.Cells(rw, 3) = "GBP"
.Cells(rw, 4) = wsS.Cells(i, 9) 'Date
.Cells(rw, 5) = "Loan"
.Cells(rw, 6) = wsS.Cells(i, 6) 'Value
.Cells(rw, 7) = "Loan"
.Cells(rw, 8) = "123"
.Cells(rw, 9) = wsS.Cells(i, 4) 'Practice Ref
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
For j = 1 To wsS.Cells(i, 7)
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
If j = 1 Then .Cells(rw, 4) = wsS.Cells(i, 9) 'Date
If j <> 1 Then .Cells(rw, 4) = Application.WorksheetFunction.EoMonth(DateAdd("m", 1, .Cells(rw - 1, 4)), 0) 'Date
.Cells(rw, 5) = "Instal " & j
.Cells(rw, 6) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
.Cells(rw, 7) = .Cells(rw, 5)
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 4)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
Next
End With
Next
End Sub
I don't believe it - I think that's actually exactly what I want!
Thank you so much, and the others who assisted.
Is there a thanks button on here?
paulked
04-18-2020, 07:09 AM
Please excuse my inadequacies, we've had a skip delivered and my wife is poking me to fill it!
This includes the invoice details as per your post No6
Sub MoveData()
Dim rw As Long, lr As Long, i As Long, j As Long, wsS As Worksheet, wsD As Worksheet
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).ClearContents
rw = 2
For i = 2 To lr
With wsD
.Cells(rw, 1) = wsS.Cells(i, 1) 'Ref
.Cells(rw, 2) = "ABC1"
.Cells(rw, 3) = "GBP"
.Cells(rw, 4) = wsS.Cells(i, 9) 'Date
.Cells(rw, 5) = "Loan"
.Cells(rw, 6) = wsS.Cells(i, 6) 'Value
.Cells(rw, 7) = "Loan"
.Cells(rw, 8) = "123"
.Cells(rw, 9) = wsS.Cells(i, 4) 'Practice Ref
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
For j = 1 To wsS.Cells(i, 7)
.Cells(rw, 1) = wsS.Cells(i, 1)
.Cells(rw, 2) = .Cells(rw - 1, 2)
.Cells(rw, 3) = .Cells(rw - 1, 3)
If j = 1 Then .Cells(rw, 4) = wsS.Cells(i, 9) 'Date
If j <> 1 Then .Cells(rw, 4) = Application.WorksheetFunction.EoMonth(DateAdd("m", 1, .Cells(rw - 1, 4)), 0) 'Date
.Cells(rw, 5) = wsS.Cells(i, 4) & "-Instalment " & j
.Cells(rw, 6) = wsS.Cells(i, 6) / wsS.Cells(i, 7) * -1
.Cells(rw, 7) = "Instal " & j
.Cells(rw, 8) = .Cells(rw - 1, 8)
.Cells(rw, 9) = wsS.Cells(i, 4)
.Cells(rw, 10) = "P" & Right(wsS.Cells(i, 1), 5)
rw = rw + 1
Next
End With
Next
End Sub
paulked
04-18-2020, 07:13 AM
No thanks required, happy to help.
Stay safe, I'm off to fill a skip!
p45cal
04-18-2020, 07:17 AM
Please excuse my inadequacies, we've had a skip delivered and my wife is poking me to fill it!
This includes the invoice details as per your post No6You're going to put TheWennerWom's invoice details into the skip?!
paulked
04-18-2020, 07:22 AM
:rofl::rofl:
p45cal
04-18-2020, 07:28 AM
No, it errors before I change anything. I'm using Office 2010, is that likely to be a factor?It begins to look like it; I was able to more or less reproduce your error by mis-spelling:
26367
I might, just for academic reasons, look for a work around that's compatible with Excel 2010, but if you're happy with paulked's solution I'll do it in my own time, …unless you say different.
p45cal
04-18-2020, 10:11 AM
See whether refreshing the new table at cell L1 of sheet To Here comes up with a new error…
TheWennerWom
04-18-2020, 10:41 PM
Hi,
Now that works (cell L1 refresh) so whatever tweak you did has resolved the problem!
Thanks both for your efforts, hopefully one day I will be able to give back to the forum :clap:
PS: don't undervalue yourselves, the knowledge you guys have is *very* impressive!
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:
26379
After:
26380
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 :thumb
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.
26381
Thanks Pascal :clap:
PS Thanks www.excelcise.org for the transpose code.
TheWennerWom
04-21-2020, 10:16 AM
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 :yes
paulked
04-21-2020, 10:35 AM
aside: snb pops in and does it in under two seconds with three lines of code :bow:
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.