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