Consulting

Results 1 to 7 of 7

Thread: VBA For Each Loop just prompting one input

  1. #1

    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 :

    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.

  2. #2
    VBAX Mentor fredlo2010's Avatar
    Joined
    Dec 2011
    Location
    Florida, USA
    Posts
    374
    Location
    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
    Feedback is the best way for me to learn


    Follow the Armies

  3. #3
    Quote Originally Posted by fredlo2010 View Post
    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.

  4. #4
    VBAX Mentor fredlo2010's Avatar
    Joined
    Dec 2011
    Location
    Florida, USA
    Posts
    374
    Location
    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
    Feedback is the best way for me to learn


    Follow the Armies

  5. #5
    Quote Originally Posted by fredlo2010 View Post
    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

  6. #6
    VBAX Mentor fredlo2010's Avatar
    Joined
    Dec 2011
    Location
    Florida, USA
    Posts
    374
    Location
    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
    Feedback is the best way for me to learn


    Follow the Armies

  7. #7

    Smile

    Quote Originally Posted by fredlo2010 View Post
    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!!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •