輸入所有必需數據后，將新數據從一個工作簿復制並粘貼到另一個工作簿

Question

我正在處理兩個工作簿。 一個工作簿（DDwb）包含交貨清單模板，而另一個工作簿（Rwb）包含已完成交貨的記錄，該記錄僅顯示交貨清單模板中的關鍵交貨信息。

每個新的交貨都顯示在模板上第14行和第27行之間的新行上。
該模板在月底保存為單獨的文件。 一個月內將在不同時間添加多個交貨。 我想在Rwb中捕獲新交付的記錄，因為它已添加到模板中。

就工作表更改事件代碼而言，一旦輸入了該交貨的所有信息，我想復制摘要信息。 例如，單元格：D14，E14，F14和N14包含當月首次交付的關鍵摘要信息。 我要等到所有這些都填滿為止。

另外，我想通過使用'With'屬性來清理'if cell value is> 0'部分，但這會導致編譯錯誤。

如何等待相關行中的單元格完全填充？

這是我到目前為止的代碼。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim DDwb As Workbook, Rwb As Workbook
    Dim cel As Range
    Dim myrow As Long

    Set DDwb = ThisWorkbook
    Set Rwb = Workbooks.Open("C:\Users\Admin\OneDrive\Documents (shared)\TEST - job and stock manager.xlsm")

    If Not Intersect(Target, Range("D14:N27")) Is Nothing Then
        For Each cel In Target
            myrow = cel.Row
            Application.EnableEvents = False
            If DDwb.Sheets("DD template (progressive)").Cells(myrow, 4).Value > 0 And DDwb.Sheets("DD template (progressive)").Cells(myrow, 5).Value > 0 And DDwb.Sheets("DD template (progressive)").Cells(myrow, 6).Value > 0 Then
                Application.ScreenUpdating = False
                'insert new row
                Rwb.Sheets("Record of deliveries").Rows("4:4").Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
                'customer name
                Rwb.Sheets("Record of deliveries").Cells(4, 2) = "Customer name"
                'customer order number
                Rwb.Sheets("Record of deliveries").Cells(4, 3) = DDwb.Sheets("DD template (progressive)").Range("D" & Target.Row)
                'delivery qty
                Rwb.Sheets("Record of deliveries").Cells(4, 4) = DDwb.Sheets("DD template (progressive)").Range("E" & Target.Row)
                'description
                Rwb.Sheets("Record of deliveries").Cells(4, 5) = DDwb.Sheets("DD template (progressive)").Range("F" & Target.Row)
                'delivery date
                Rwb.Sheets("Record of deliveries").Cells(4, 6) = "=TODAY()"
                'DD docket number
                Rwb.Sheets("Record of deliveries").Cells(4, 7) = DDwb.Sheets("DD template (progressive)").Range("L" & Target.Row)
                'delivery notes
                Rwb.Sheets("Record of deliveries").Cells(4, 8) = DDwb.Sheets("DD template (progressive)").Range("N" & Target.Row)
                Rwb.Save
                Application.ScreenUpdating = True
                Application.EnableEvents = True
            End If
        Next cel
    End If

End Sub

Answer 1

• 我很確定此Worksheet_Change位於私有DD模板（漸進式）工作表代碼表上，因此對ThisWorkbook和DDwb.Sheets（“ DD模板（漸進式）”）的所有引用都是多余的。
• 您僅從D，E，F，L和N列傳輸值，因此僅需要填充這些單元格。
• 您正在使用=today()公式，但我認為您需要一個靜態Date 。 您可以根據需要還原此設置。
• 在您真正需要它們之前，無需對var進行變暗和打開工作簿。
• 不需要在循環中禁用/啟用EnableEvents和ScreenUpdating 。 在循環之前禁用一次，並在循環結束后重新啟用。
• 您一直想打開目標工作簿而不關閉它。 我假設您想在動作之間將其關閉。
• 您只需要傳輸一次值，因此您需要收集所涉及行的唯一列表。 不是Target中所有單元的完整列表。
• 提供一些錯誤控制通常是個好主意。

_{完整的測試沙箱需要人工構建外部工作簿，因此尚未經過全面測試。}

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("D:F, L:L, N:N"), Range("14:27")) Is Nothing Then
        On Error GoTo safe_exit
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Dim rw As Range
        Static dict As Object, ky As Variant

        If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")
        dict.RemoveAll

        For Each rw In Intersect(Target, Range("D:F, L:L, N:N"), Range("14:27")).Rows
            'are there 5 values in D:F, L, N of this row?
            If Application.CountA(Intersect(Range("D:F, L:L, N:N"), Rows(rw.Row))) = 5 Then _
                dict.Item(rw.Row) = vbNullString
        Next rw

        if cbool(dict.count) then 
            'we finally know that there are values to transfer; time to open the external workbook
            dim vals As Variant, rwb As Workbook
            Set rwb = Workbooks.Open("C:\Users\Admin\OneDrive\Documents (shared)\TEST - job and stock manager.xlsm")
            For Each ky In dict.keys
               'there are 5 values in D:F, L, N of this row - insert new row
                rwb.Sheets("Record of deliveries").Rows("4:4").Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
                'collect values
                vals = Array("Customer name", Cells(ky, "D").Value, Cells(ky, "E").Value, Cells(ky, "F").Value, _
                              Date, Cells(ky, "L").Value, Cells(ky, "N").Value)
                'transfer values
                rwb.Sheets("Record of deliveries").Cells(4, 2).Resize(1, 7) = vals
            Next ky

            rwb.Close SaveChanges:=True
        End If
    End If

safe_exit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub