根據單元格輸入將行信息從一個工作表復制到另一個工作表

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