指定列中的单元格更改时复制表格的一行
我试图复制表格中的行，当一个指定的列中的单元格插入数据，然后将此行粘贴到另一个表。
表格开始在单元格A3是表格的第一个标题，它是9列长，将会有无穷多的行。
要监视更改的列是第8列，名为“date完成”。 input的信息应始终为date，格式为“dd mmm”。
该行需要被复制到与input到第8列中的date相同的名单上，在inputdate之前该date可能不存在。
在复制完成之前，我想要一个文本框将注释input到名为“注释”的第9列的相应单元格中。
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
下面看起来相当健壮，并且会接受粘贴到列H中的多个值。我build议在Application.EnableEvents = False代码行上设置一个断点，并在H列中input一个date。一旦到达断点，就可以遍历每个与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代码行以避免屏幕闪烁。