VBA For Each Loop just prompting one input

[mattyg1406]

Hello,

I am trying to write some code that will insert copied rows in a worksheet. I want to prompt the user to specify which row # to copy and how many payments to create (i.e. 3 entered, will insert 2 copied rows). I then want to ask the user for a new amount for each payment (in column G), including overwriting the original value. e.g. 1 row = 3 payments = 2 copied rows inserted = 3 new amounts prompted. However, the following code just asks for 1 new amount and places it in column G of the row number selected. Here is the code :


Dim RowtoCopy As Long

RowtoCopy = Application.InputBox( _
Prompt:="Row Number of Voucher to Copy", _
Title:="Voucher Payments", _
Type:=1)

If RowtoCopy < 1 Then Exit Sub

Dim HowManyCopies As Long

HowManyCopies = Application.InputBox( _
Prompt:="How many Payments within this Voucher?", _
Title:="Voucher Payments", _
Type:=1) - 1

If HowManyCopies < 1 Then Exit Sub

Rows(RowtoCopy).Select
ActiveCell.Offset(1).Resize(HowManyCopies).EntireRow.Insert
ActiveCell.EntireRow.Copy ActiveCell.Offset(1).Resize(HowManyCopies).EntireRow

With ActiveCell.Resize(SplitAmount + 1, 1).EntireRow
For Each oneCell In .Columns("G").Cells:

SplitAmount = Application.InputBox( _
Prompt:="Enter value for " & .Address, _
Title:="Split Voucher Payments", _
Type:=7)
If SplitAmount <> False Then oneCell.Value = SplitAmount

Next oneCell
End With

Where am I going wrong?
Any help much appreciated.

[fredlo2010]

Hi,

Try this


Option Explicit

Sub Thius()


Dim lRowtoCopy As Long
Dim lHowManyCopies As Long
Dim dblTotal As Long
Dim r As Range

' Determine the row to copy and the amount of copies.
lRowtoCopy = InputBox("Row Number of Voucher to Copy", Title:="Voucher Payments")
lHowManyCopies = InputBox("How many Payments within this Voucher?", "Voucher Payments")


If Not lRowtoCopy < 1 And Not lHowManyCopies < 1 Then
' Copy the rows.
Rows(lRowtoCopy).Copy
Rows(lRowtoCopy).Resize(lHowManyCopies - 1).EntireRow.Insert
Application.CutCopyMode = False


' Distribute the amounts.
dblTotal = Range("G" & lRowtoCopy).Value

For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r

' Check the totals
If Not Application.Sum(Range("G" & lRowtoCopy).Resize(lHowManyCopies)) = dblTotal Then
Range("G" & lRowtoCopy).Value = dblTotal
Range("G" & lRowtoCopy).Offset(1).Resize(lHowManyCopies - 1).Value = 0

MsgBox "Your totals do not match. The total has been allocated to the original voucher."
End If

End If

End Sub

Thanks

[mattyg1406]

Hi,

Try this


Option Explicit

Sub Thius()


Dim lRowtoCopy As Long
Dim lHowManyCopies As Long
Dim dblTotal As Long
Dim r As Range

' Determine the row to copy and the amount of copies.
lRowtoCopy = InputBox("Row Number of Voucher to Copy", Title:="Voucher Payments")
lHowManyCopies = InputBox("How many Payments within this Voucher?", "Voucher Payments")


If Not lRowtoCopy < 1 And Not lHowManyCopies < 1 Then
' Copy the rows.
Rows(lRowtoCopy).Copy
Rows(lRowtoCopy).Resize(lHowManyCopies - 1).EntireRow.Insert
Application.CutCopyMode = False


' Distribute the amounts.
dblTotal = Range("G" & lRowtoCopy).Value

For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r

' Check the totals
If Not Application.Sum(Range("G" & lRowtoCopy).Resize(lHowManyCopies)) = dblTotal Then
Range("G" & lRowtoCopy).Value = dblTotal
Range("G" & lRowtoCopy).Offset(1).Resize(lHowManyCopies - 1).Value = 0

MsgBox "Your totals do not match. The total has been allocated to the original voucher."
End If

End If

End Sub

Thanks

This is really good thanks . . . just one slight thing it doesn't seem to cope with amounts that have decimals, e.g. 1 voucher is 407.33, with 243.00 and 164.33 as the splits. I enter these 2 amounts, and the msgbox comes up, and leaves 407.00 in the original voucher amount.

[fredlo2010]

I am sorry my bad,

Change this section


For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r


with this:


For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = Application.InputBox("Enter value for " & r.Address, "Split Voucher Payments", , , , , , 7)
Next r


Thanks

[mattyg1406]

I am sorry my bad,

Change this section


For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r


with this:


For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = Application.InputBox("Enter value for " & r.Address, "Split Voucher Payments", , , , , , 7)
Next r


Thanks

I'm afraid that didn't make any difference

[fredlo2010]

lol I was been silly

use this code



Option Explicit


Sub SplitVouchers()




Dim lRowtoCopy As Long
Dim lHowManyCopies As Long
Dim dblTotal As Double
Dim r As Range

' Determine the row to copy and the amount of copies.
lRowtoCopy = Val(InputBox("Row Number of Voucher to Copy", Title:="Voucher Payments"))
lHowManyCopies = Val(InputBox("How many Payments within this Voucher?", "Voucher Payments"))


If Not lRowtoCopy < 1 And Not lHowManyCopies < 1 Then
' Copy the rows.
Rows(lRowtoCopy).Copy
Rows(lRowtoCopy).Resize(lHowManyCopies - 1).EntireRow.Insert
Application.CutCopyMode = False


' Distribute the amounts.
dblTotal = Range("G" & lRowtoCopy).Value

For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r

' Check the totals
If Not CStr(Application.Sum(Range("G" & lRowtoCopy).Resize(lHowManyCopies))) = CStr(dblTotal) Then
Range("G" & lRowtoCopy).Value = dblTotal
Range("G" & lRowtoCopy).Offset(1).Resize(lHowManyCopies - 1).Value = 0

MsgBox "Your totals do not match. The total has been allocated to the original voucher."
End If

End If

End Sub


Thanks

[mattyg1406]

lol I was been silly

use this code



Option Explicit


Sub SplitVouchers()




Dim lRowtoCopy As Long
Dim lHowManyCopies As Long
Dim dblTotal As Double
Dim r As Range

' Determine the row to copy and the amount of copies.
lRowtoCopy = Val(InputBox("Row Number of Voucher to Copy", Title:="Voucher Payments"))
lHowManyCopies = Val(InputBox("How many Payments within this Voucher?", "Voucher Payments"))


If Not lRowtoCopy < 1 And Not lHowManyCopies < 1 Then
' Copy the rows.
Rows(lRowtoCopy).Copy
Rows(lRowtoCopy).Resize(lHowManyCopies - 1).EntireRow.Insert
Application.CutCopyMode = False


' Distribute the amounts.
dblTotal = Range("G" & lRowtoCopy).Value

For Each r In Range("G" & lRowtoCopy).Resize(lHowManyCopies)
r.Value = InputBox("Enter value for " & r.Address, "Split Voucher Payments")
Next r

' Check the totals
If Not CStr(Application.Sum(Range("G" & lRowtoCopy).Resize(lHowManyCopies))) = CStr(dblTotal) Then
Range("G" & lRowtoCopy).Value = dblTotal
Range("G" & lRowtoCopy).Offset(1).Resize(lHowManyCopies - 1).Value = 0

MsgBox "Your totals do not match. The total has been allocated to the original voucher."
End If

End If

End Sub


Thanks

Fantastic, many thanks for your help!!