Moving data between two sheets VBA

[TheWennerWom]

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]

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]

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]

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]

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]

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]

Got it. Take a look at Pascals solution, that does that (he's psychic!)

[TheWennerWom]

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]

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]

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]

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]

No, it errors before I change anything. I'm using Office 2010, is that likely to be a factor?

[TheWennerWom]

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]

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]

No thanks required, happy to help.

Stay safe, I'm off to fill a skip!

[p45cal]

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]

:rofl::rofl:

[p45cal]

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]

See whether refreshing the new table at cell L1 of sheet To Here comes up with a new error…

[TheWennerWom]

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]

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]

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]

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]

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]

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]

Wow!

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

[paulked]

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