Vba 当指定列中的单元格更改时复制表中的行

当指定列中的单元格插入数据时，我试图复制表中的行，然后将该行粘贴到另一个工作表中

表格从单元格

A3

开始，是表格的第一个标题，它有9列长，将有无数行

要监视更改的列是第8列，名为“完成日期”。输入的信息应始终为日期，格式为“dd mmm”

需要将该行复制到与在第8列中输入的日期同名的工作表上，该工作表在输入日期之前可能不存在

同样，在复制完成之前，我希望有一个文本框将注释输入第9列中名为“注释”的相应单元格

---

下面的代码看起来非常健壮，可以接受粘贴到H列中的多个值。我建议在

Application.EnableEvents=False

code行上设置一个断点，并在H列中键入一个日期。到达断点后，可以使用F8键单步遍历每一行

我留下了一些额外的内容，如将原始工作表的标题复制到新工作表中、冻结新工作表上的第1行、缩放新工作表等。如果您觉得这些内容没有帮助，请删除或调整它们

---

当您对代码进行了所有调整后，请取消注释Application.ScreenUpdate=False代码行，以避免屏幕闪烁。

哪一部分特别让您感到困惑？目前我担心，我已经将其中一些元素放入了以前的电子表格中，它们已经工作了，我只是不确定如何将它们全部合并。试着把问题分解成几个小部分，一次解决一个。要开始，请看一看。堆栈溢出是为了帮助解决特定问题，而不是指导您如何解决整个问题。如果有帮助的话，我已经添加了我当前的代码

Private Sub Worksheet_change(ByVal Target As Range)

   Const lngdatecomplete As Long = 8

   Dim wks As Worksheet

   Dim lngNextAvailableRow As Long

   If Target.Areas.Count = 1 And Target.Cells.Count = 1 Then

      If Not Intersect(Target, Columns(lngdatecomplete)) Is Nothing Then                            

         On Error Resume Next
         Set wks = ThisWorkbook.Worksheets(Target.Value)
         On Error GoTo 0

         If wks Is Nothing Then

            lngNextAvailableRow = wks.Range("a1").CurrentRegion.Rows.Count + 1
            ActiveSheet.Range(Cells(Target.Row, 2), Cells(Target.Row, 8)).copy _
             wks.Range("A" & lngNextAvailableRow).PasteSpecial

         ElseIf Not wks Is Nothing Then

            Dim ShtName$

            Sheets.Add after:=Sheets(Sheets.Count)

            ShtName = Format(Date, "dd mmm")

            Sheets(Sheets.Count).Name = ShtName

            Sheets(ShtName).Visible = True

            lngNextAvailableRow = wks.Range("a1").CurrentRegion.Rows.Count + 1
            ActiveSheet.Range(Cells(Target.Row, 2), Cells(Target.Row, 8)).copy _
             wks.Range("A" & lngNextAvailableRow).PasteSpecial

         End If
      End If
   End If
End Sub

Private Sub Worksheet_change(ByVal Target As Range)
    Const lDATECMPLT As Long = 8

    If Not Intersect(Target, Columns(lDATECMPLT)) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        'Application.ScreenUpdating = False
        Application.EnableEvents = False
        Dim trgt As Range
        For Each trgt In Intersect(Target, Columns(lDATECMPLT))
            If trgt.Row > 3 And IsDate(trgt) Then
                trgt.NumberFormat = "dd mmm"
                On Error GoTo bm_Need_WS
                With Worksheets(trgt.Text)
                    On Error GoTo bm_Safe_Exit
                    trgt.Resize(1, 7).Offset(0, -6).Copy _
                      Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                    'optional mark the row copied
                    'With trgt.Resize(1, 7).Offset(0, -6).Font
                    '    .Strikethrough = True
                    '    .Color = RGB(120, 120, 120)
                    'End With
                End With
            End If
        Next trgt
    End If
    GoTo bm_Safe_Exit

bm_Need_WS:
    On Error GoTo 0
    With Worksheets.Add(after:=Sheets(Sheets.Count))
        .Name = trgt.Text
        .Visible = True
        .Cells(1, 1).Resize(1, 7) = Me.Cells(3, 2).Resize(1, 7).Value2
        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
            .Zoom = 80
        End With
    End With
    Resume

bm_Safe_Exit:
    Application.EnableEvents = True
    Me.Activate
    Application.ScreenUpdating = True
End Sub