根据单元格input将行信息从一个表格复制到另一个表格
我多年没有编码，所以生病的时候尽我所能去沟通我的目标。
我有一个Master工作表，其中包含许多项目列表（列在大师与他们自己的细胞），同样有自己的编号表。 这个大师有关于行中的所有其他项目的信息，当在适当的单元格下select时，将复制该行信息到适用的项目表中的下一个可用的行。
Private Sub Worksheet_Change(ByVal Target As Range) Dim nextrow As Long, lastrow As Long, i As Long nextrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet5.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet6.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet8.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet9.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet10.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet11.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet12.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet13.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet14.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet15.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet16.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet17.Cells(Rows.Count, "A").End(xlUp).Row + 1 lastrow = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row + 1 If Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False If Not Intersect(Target, Range("C5:C" & lastrow)) Is Nothing Then If Target <> vbNullString Then i = Target.Row Range("A" & i & ":B" & i).Copy Destination:=Sheet1.Range("A" & nextrow) End If End If 这前6行代码重复每个图纸号码，直到它到达最后一页（表17和单元格Q），然后是：
Application.ScreenUpdating = True end Sub
这可以工作，但是当它复制信息时，它将replace现有的信息，而不是将它放在下一个可用的行中。 除了最后的项目表是这样的情况。 最后一张工作正常。
只是你在每次计算时都会覆盖 nextrow ，所以你只会在事实上有这个nextrow = Sheet17.Cells(Rows.Count, "A").End(xlUp).Row + 1 。
你需要像这样改变结构：
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False Dim nextrow As Long, lastrow As Long, i As Long lastrow = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row + 1 nextrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row + 1 If Not Intersect(Target, Range("C5:C" & lastrow)) Is Nothing Then If Target <> vbNullString Then i = Target.Row Range("A" & i & ":B" & i).Copy Destination:=Sheet1.Range("A" & nextrow) End If End If nextrow = Sheet5.Cells(Rows.Count, "A").End(xlUp).Row + 1 If Not Intersect(Target, Range("C5:C" & lastrow)) Is Nothing Then If Target <> vbNullString Then i = Target.Row Range("A" & i & ":B" & i).Copy Destination:=Sheet5.Range("A" & nextrow) End If End If nextrow = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row + 1 'And so ON....
或者与一个工作表的对象数组：
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False Dim NextRow As Long, LastRow As Long, i As Long, Sh() As Variant, Ws As Worksheet LastRow = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row + 1 ReDim Sh(1 To 15, 1 To 2) Set Sh(1, 1) = Sheet1: Sh(1, 2) = "C5:C" Set Sh(2, 1) = Sheet5: Sh(2, 2) = "D5:D" Set Sh(3, 1) = Sheet4: Sh(3, 2) = "E5:E" Set Sh(4, 1) = Sheet6: Sh(4, 2) = "F5:F" Set Sh(5, 1) = Sheet7: Sh(5, 2) = "G5:G" Set Sh(6, 1) = Sheet8: Sh(6, 2) = "H5:H" Set Sh(7, 1) = sheet9: Sh(7, 2) = "I5:I" Set Sh(8, 1) = sheet10: Sh(8, 2) = "J5:J" Set Sh(9, 1) = sheet11: Sh(9, 2) = "K5:K" Set Sh(10, 1) = sheet12: Sh(10, 2) = "L5:L" Set Sh(11, 1) = sheet13: Sh(11, 2) = "M5:M" Set Sh(12, 1) = Sheet14: Sh(12, 2) = "N5:N" Set Sh(13, 1) = Sheet15: Sh(13, 2) = "O5:O" Set Sh(14, 1) = sheet16: Sh(14, 2) = "P5:P" Set Sh(15, 1) = Sheet17: Sh(15, 2) = "Q5:Q" For k = LBound(Sh, 1) To UBound(Sh, 1) Set Ws = Sh(k, 1) NextRow = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row + 1 If Not Intersect(Target, Range(Sh(k, 2) & LastRow)) Is Nothing Then If Target <> vbNullString Then i = Target.Row Range("A" & i & ":B" & i).Copy Destination:=Ws.Range("A" & NextRow) End If End If Next k Application.ScreenUpdating = True End Sub