Копирование информации о строках с одного листа на другой, основанный на вводе ячеек

Question

Я havent закодирован за многие годы, так что стараюсь изо всех сил связывать свою цель.

У меня есть листок, содержащий список многих проектов (перечисленных в Мастере со своей собственной ячейкой), которые также имеют свои собственные пронумерованные листы. Этот Мастер имеет информацию, относящуюся ко всем другим проектам в строках, которые при выборе под соответствующей ячейкой копируют информацию о строках в следующую доступную строку в соответствующей странице проекта.

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), а затем Theres:

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