如何使用VBA将记录从Excel表单存储到不同的行？

Question

所以我在Excel工作簿InvoiceForm.xlsm的Sheet Invoice_Form中有这样的发票表单：

以及Excel工作簿InvoiceDatabase.xlsm的工作表Invoice Database中的发票记录数据库：

我已经创建了可以将表单中的记录链接到发票数据库的VBA代码，但是代码现在可以做的只是记录发票表单的第一行：

代码如下所示：

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

所以问题是：如果在发票表单中添加了其他产品，我如何修改我的代码，以便它可以根据这一个表单在不同的行上创建多个记录？

谢谢！

Answer 1

从表单构建数组并将数组转储到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

Answer 2

您真的应该使用表单/访问数据库或Excel数据表单（2016）来执行此操作。

也就是说，您的代码将覆盖每一行作为您对另一个工作表的写入，因为它不会增加。此外，您错过了添加日期和发票号码的方式。

以下使用更有意义的名称并添加缺失的数据，以及一些基本的错误检查（例如，有数据要传输）以及在转移后清除表单方面的内务管理。

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