VBA For Each Loop just prompting one input

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 :

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.

Hi,

Try this

Code:

---

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

Quote:

---

Originally Posted by fredlo2010

Hi,

Try this

Code:

---

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.

I am sorry my bad,

Change this section

Code:

---

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

---

with this:

Code:

---

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

Quote:

---

Originally Posted by fredlo2010

I am sorry my bad,

Change this section

Code:

---

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

---

with this:

Code:

---

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

lol I was been silly

use this code

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

Quote:

---

Originally Posted by fredlo2010

lol I was been silly

use this code

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!!