View Full Version : VBA For Each Loop just prompting one input
mattyg1406
02-10-2015, 09:57 AM
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
02-10-2015, 12:00 PM
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
02-10-2015, 01:01 PM
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
02-10-2015, 01:42 PM
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
02-10-2015, 02:08 PM
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
02-10-2015, 03:21 PM
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
02-11-2015, 03:47 AM
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!!
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.