时间戳

首页 > 解决方案 > 输入所有必需数据后，将新数据从一个工作簿复制并粘贴到另一个工作簿

excel - 输入所有必需数据后，将新数据从一个工作簿复制并粘贴到另一个工作簿

问题描述

我正在使用两本工作簿。一个工作簿 (DDwb) 包含一个交付记录模板，另一个工作簿 (Rwb) 包含已完成交付的记录，仅显示来自交付记录模板的关键交付信息。

每个新交货都会出现在模板上第 14 行和第 27 行之间的新行上。
此模板在月底保存为单独的文件。多个交付将在一个月内的不同时间添加。我想在 Rwb 中捕获新交付的记录，因为它已添加到模板中。

就工作表更改事件代码而言，我想在输入该交付的所有信息后复制摘要信息。例如，单元格：D14、E14、F14 和 N14 包含当月第一次交付的关键摘要信息。我想等到这一切都填满了。

另外，我想通过使用“With”属性来清理我的“如果单元格值> 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

标签： excelvba

解决方案

  • 我很确定这个 Worksheet_Change 位于私有DD 模板（渐进式）工作表代码表上，因此对 ThisWorkbook 和 DDwb.Sheets("DD template (progressive)") 的所有引用都是多余的。
  • 您仅从 D、E、F、L 和 N 列传输值，因此只需要填充这些单元格。
  • 您正在使用=today()公式，但我认为您想要一个 static Date。如果你愿意，你可以恢复它。
  • 在您知道自己确实需要它们之前，没有必要对变量进行暗淡和打开工作簿。
  • 禁用/启用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

推荐阅读