Question

当指定列中的单元格插入数据时，我尝试复制表格中的行，然后将此行粘贴到另一张表格中。

该表从单元格A3开始，它是表格的第一个标题，长度为9列，行数无穷无尽。

要监控更改的列是第8列，名为＆＃34;日期完成＆＃34;。输入的信息应始终为日期，格式＆＃34; dd mmm＆＃34;。

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

在复制完成之前，我想要一个文本框在第9列的相应单元格中输入注释，命名为＆＃34;注释＆＃34;。

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

Answer 1

以下内容看起来非常强大，并且会接受粘贴到列H中的多个值。我建议在Application.EnableEvents = False代码行上设置断点并在列H中键入日期。一旦到达断点，就可以使用 F8 键逐步执行每一行。

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

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

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

当指定列中的单元格发生更改时，复制表的一行

1 个答案: