根據單元格輸入將行信息從一個表格複製到另一個表格

Question

我很多年沒有編碼，所以生病時盡我最大的努力來溝通我的目標。

我有一個主表單，其中包含許多項目列表（在他們自己的單元格中列出），同樣也有自己的編號表。此主人信息與行中的所有其他項目有關，在適當的單元格下選中時，會將該行信息複製到適用項目表中的下一個可用行。

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