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