Question

我有一个电子表格，我在A-K列中添加了一个人的详细信息See image

我正在尝试使用VBA来运行代码，每次L行有＆＃34;是＆＃34;在其中，然后在M-T列中查找任何＆＃34;是＆＃34;并从当前工作表中复制整行＆＃34; New Refs＆＃34;到相应的标签（例如，如果＆＃34;是＆＃34;在M栏中，将行复制到＆＃34; ASD 5P＆＃34;标签）。

我有以下代码，但它会覆盖已存在的行。我需要它来查找相应选项卡中的下一个空行，并将其粘贴到该行，而不覆盖或删除已存在的其他行。这是我目前使用的代码......

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

请指教？

更新我的标题行看起来像this

Answer 1

不得不在工作中完成一些事情但是......有不同的方法可以解决这个问题，下面是一个：

以下是我做的假设：

触发列将在您的工作表中为Column L
您只想从Column A复制到Column K
要检查复制行的工作表中是否已存在行，我使用RIO（Column C）作为唯一标识符

在Worksheet_Change子组中，根据下面的屏幕截图调用CopyCurrentRowToSheets sub（注意：我在开发此代码时使用了Sheet8）：

通过以下方式添加对Microsoft Scripting Runtime的引用：在您的VBA编辑器中，选择工具菜单。然后选择参考... 选项。这将打开参考窗口（下面的屏幕打印）。向下滚动并从列表中选择 Microsoft Scripting Runtime ，然后按确定按钮

然后在模块中添加以下子项：

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

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

1 个答案: