根据单元格输入将行信息从一个工作表复制到另一个工作表

Question

多年来我没有编码，所以尽力传达我的目标。

我有一个主表单，其中包含许多项目的列表（在主服务器中列出了他们自己的单元格），它们同样有自己的编号表。 此Master具有与行中所有其他项目相关的信息，在相应单元格下选择时，将该行信息复制到适用项目表中的下一个可用行。

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

这有效，但是当它复制信息时，它会替换现有信息，而不是将其放在下一个可用行中。 无论上一个项目表是什么，都是例外情况。 最后一张纸按预期工作。

Answer 1

只是你在开始的每一次计算中都覆盖了 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