Excel VBA：将行复制到另一张工作表的下一个空白行时出现问题

Question

I have a spreadsheet where I add a person's details in columns AK See image

I am trying to use VBA to run code everytime row L has "Yes" in it, and then look for any "Yes"'s in columns MT and copy the entire row from the current sheet "New Refs" to the corresponding tab (eg. if "Yes" in column M, copy the row to the "ASD 5P" tab).

I have the following code, but it keeps overwriting rows that are already there. I need it to look for the next blank row in the corresponding tab, and paste it to that, without overwriting or deleting the other rows that are already there. Here is the code I am using currently...

Sub Worksheet_Change(ByVal Target As Range)
  Dim KeyCells As Range

  ' The variable KeyCells contains the cells that will
  ' cause an alert when they are changed.
  Set KeyCells = Range("K:S")

  If Not Application.Intersect(KeyCells, Range(Target.Address)) _
       Is Nothing Then

  Application.ScreenUpdating = False
  Dim lastrow As Long
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Dim x As Long
  x = 4
  Dim rng As Range
  For Each rng In Sheets("New Refs").Range("M4:M" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("ASD 5P").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True


  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("N4:N" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("ASD PD").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True

  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("O4:O" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("IY Group").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True

  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("P4:P" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("Dina").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True

  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("Q4:Q" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("Indiv. Par.").Cells(x, 1)
          x = x + 1
      End If
 Next rng
  Application.ScreenUpdating = True   

  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("R4:R" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("ASD Psy. Ed.").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True

  Application.ScreenUpdating = False
  lastrow = Sheets("New Refs").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  x = 4
  For Each rng In Sheets("New Refs").Range("S4:S" & lastrow)
      If rng.Value2 = "Yes" And Trim(Cells(rng.Row, "K")) <> vbNullString And Trim(Cells(rng.Row, "L")) = "Yes" Then
          rng.EntireRow.Copy Sheets("ADHD Psy. Ed.").Cells(x, 1)
          x = x + 1
      End If
  Next rng
  Application.ScreenUpdating = True   
  End If
End Sub

Please advise?

UPDATE My header rows look like this

Answer 1

Had to get some things finished at work but.. there are different ways you can approach this, below is one:

Following are the assumption I made:

• Trigger column will be Column L in your sheet
• You only want to copy from Column A to Column K
• To check if row already exists in the sheets where row is copied, I am using RIO ( Column C ) as a unique identifier

In your Worksheet_Change sub make the call to CopyCurrentRowToSheets sub as per screenshot below (NOTE: I used Sheet8 when developing this code):

Add reference to Microsoft Scripting Runtime by: In your VBA editor, select the Tools menu. Then select References... option. This will open References window (screen print below). Scroll down and select Microsoft Scripting Runtime from the list and press OK button

Then in a module, add the following sub:

Sub CopyCurrentRowToSheets(ByVal oTarget As Range)
    Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet8")     ' Change the sheet name
    Dim oWS As Worksheet
    Dim dSTU As New Scripting.Dictionary     ' Requires reference to Microsoft Scripting Runtime
    Dim oRange As Range
    Dim iLR As Long

    ' Capture sheets to update
    For Each oRange In oW.Range("M" & oTarget.Row & ":" & Chr(oW.Cells(1, oW.Columns.count).End(xlToLeft).Column + 64) & oTarget.Row)
        dSTU.Add Cells(1, oRange.Column).Value, oRange.Value
    Next

    ' Check if we need to update the sheets by checking the value in column L
    If Trim(LCase(oTarget.Value)) = "yes" Then

        ' Loop to go through all sheets in current workbook
        For Each oWS In ThisWorkbook.Worksheets

            ' Check if current sheet is one of the sheet that need updating
            If dSTU.Exists(oWS.Name) Then

                ' Check if current sheet should be updated
                If Trim(LCase(dSTU(oWS.Name))) = "yes" Then

                    ' Check if current row already exists in the target sheet
                    If Application.IfNa(Application.Match(oW.Cells(oTarget.Row, 3).Value, oWS.Columns(3), 0), "") = "" Then
                        iLR = oWS.Range("A" & oWS.Rows.count).End(xlUp).Row + 1
                        oW.Range("A" & oTarget.Row & ":K" & oTarget.Row).Copy oWS.Range("A" & iLR & ":K" & iLR)
                    End If

                End If
            End If

        Next

    End If

End Sub