How to store records from an Excel form to different rows using VBA?

2
votes

so I have this invoice form that looks like this in Sheet Invoice_Form of an Excel workbook InvoiceForm.xlsm:

enter image description here

and a database of invoice records in Sheet Invoice Database of an Excel workbook InvoiceDatabase.xlsm: enter image description here

I have created VBA codes that can link records from the form to the invoice database, but what the code manages to do right now is only recording the first row of the invoice form: enter image description here

The code looks like this:

Sub Submit_Invoice()

  Dim LastRow As Long, ws As Worksheet

  Set ws = Sheets("InvoiceDatabase") 

  LastRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 

  ws.Range("K" & LastRow).Value = Worksheets("Invoice Form").Range("C9:C16").Value 
  ws.Range("L" & LastRow).Value = Worksheets("Invoice Form").Range("D9:D16").Value
   ....

 End Sub

So the question is: How do I modify my code so that it can create multiple records on different rows based on this one form if there are additional products added in the invoice form?

Thanks!

2
vbaexcel
Are you using Excel 2016? You could just use the inbuilt data entry forms. Also, how is D5 and D6 being transferred across? - QHarr
Yes, I am using Excel 2016 but in this case I can't use data entry form. Anyway I modified the code already as D5 and D6 is not the problem here, thanks for pointing it out! - user71812

2 Answers

2
votes

Build an array from the form and dump the array into the InvoiceDatabase.

Sub Submit_Invoice()

    Dim lr As Long, ws As Worksheet
    dim arr as variant, i as long

    with Worksheets("Invoice Form")
        lr = .cells(16, "C").end(xlup).row - 8
        redim arr(1 to lr, 1 to 6)
        for i=lbound(arr,1) to ubound(arr, 1)
            arr(i, 1) = .cells(5, "D").value
            arr(i, 2) = .cells(6, "D").value
            arr(i, 3) = .cells(i+8, "C").value
            arr(i, 4) = .cells(i+8, "D").value
            arr(i, 5) = .cells(i+8, "E").value
            arr(i, 6) = .cells(i+8, "F").value
        next i
    end with

    WITH WORKSheets("InvoiceDatabase")
        lr = .Range("I" & .Rows.Count).End(xlUp).Row + 1
        .cells(lr, "I").resize(ubound(arr, 1), ubound(arr, 2)) = arr
    end with

 End Sub
2
votes

You really should use a form/access database or Excel data form (2016) to do this.

That said, your code is overwriting each row as your write to the other sheet as it isn't incremented. Also, you are missing how you add dates and invoice numbers.

The following uses more meaningful names and adds in the missing data, along with some basic error checks (e.g. there is data to transfer) and housekeeping in terms of clearing the form after transfer.

Option Explicit
Public Sub Submit_Invoice()
    Dim nextRowDest As Long, lastRowSource As Long, wsDest As Worksheet, wsSource As Worksheet, transferData As Range
    Dim invoiceInfo As Range
    Application.ScreenUpdating = False

    Set wsDest = ThisWorkbook.Worksheets("InvoiceDatabase")
    Set wsSource = Workbooks("Invoice_Form.xlsm").Worksheets("Invoice Form")

    With wsSource
        lastRowSource = wsSource.Range("C" & .Rows.Count).End(xlUp).Row
        If lastRowSource < 9 Then Exit Sub       '<==No data
        Set transferData = .Range("C9:G" & lastRowSource)
        Set invoiceInfo = .Range("D5:D6")
    End With

    With wsDest
        nextRowDest = wsDest.Range("I" & Rows.Count).End(xlUp).Row + 1
        If nextRowDest < 4 Then Exit Sub         '<==Assume headers are in row 3
        transferData.Copy .Range("K" & nextRowDest)
        invoiceInfo.Copy
        .Range("I" & nextRowDest).Resize(transferData.Rows.Count, invoiceInfo.Rows.Count).PasteSpecial Transpose:=True
    End With

    transferData.ClearContents
    invoiceInfo.ClearContents

    Application.ScreenUpdating = True

End Sub