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

Question

I havent coded in many years so ill do my best at communicating my objective.

I have a Master sheet that contains a list of many projects (listed in the Master with their own cell) that likewise have their own numbered sheets. This Master has info that pertains to all other projects in the rows, that when selected under the appropriate cell, will copy that rows info to the next available row in the applicable project sheet.

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

This the previous 6 lines of code are repeated for every sheet number until it gets to the last sheet (Sheet 17 and cell Q), and then theres the:

 Application.ScreenUpdating = True
end Sub

This works, however when it copies the info over, it replaces the existing info rather than place it in the next available row. This is the case EXCEPT for whatever the last project sheet is. The last sheet works as intended.

Answer 1

It is just that you overwrite nextrow at every calculation that you made on the start, so you'll only have this in facts nextrow = Sheet17.Cells(Rows.Count, "A").End(xlUp).Row + 1 .

You need to change the structure like this :

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....

---

Or with an Array of Worksheets' Objects :

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