Question

我有一个电子表格，我在列A-J中输入人员详细信息，然后在列K中指示是，如果他/她被提交ASD 5P或列L用于ASD PD。当我进入＆＃39;是＆＃39;在其中一列或两列中，我想将该行的A：L列复制到相关选项卡。我有以下代码复制整行，但我希望它停在L列。这是我一直在使用的代码（从各个站点复制和改编）。有人可以帮我修改一下吗？！？ This is what my spreadsheet looks like

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

    Set KeyCells = Range("K:L")

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

    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim x As Long
    x = 3
    Dim rng As Range
    For Each rng In Sheets("Sheet1").Range("K3:K" & LastRow)
        If rng = "Yes" Then
            rng.EntireRow.Copy Sheets("ASD 5P").Cells(x, 1)
            x = x + 1
            ActiveSheet.Range("A3:Q200").RemoveDuplicates Columns:=Array(4, 5, 6), Header:=xlNo
        End If
    Next rng
    Application.ScreenUpdating = True


    Application.ScreenUpdating = False
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    x = 3
    For Each rng In Sheets("Sheet1").Range("L3:L" & LastRow)
        If rng = "Yes" Then
            rng.EntireRow.Copy Sheets("ASD PD").Cells(x, 1)
            x = x + 1
            ActiveSheet.Range("A3:Q200").RemoveDuplicates Columns:=Array(4, 5, 6), Header:=xlNo
        End If
    Next rng
    Application.ScreenUpdating = True
    End If
End Sub

Answer 1

建议重写（太长，不适合评论！）。我也不确定你是否需要删除循环中的重复项，但是因为不确定它是什么而留下来。

Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range
Dim LastRow As Long
Dim x As Long, y As Long
Dim rng As Range

Set KeyCells = Range("K:L")

If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
    Application.ScreenUpdating = False
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    x = 3: y = 3

    For Each rng In Sheets("Sheet1").Range("K3:K" & LastRow)
        If rng = "Yes" Then
            Sheets("Sheet1").Cells(rng.Row, 1).Resize(, 12).Copy Sheets("ASD 5P").Cells(x, 1)
            x = x + 1
            ActiveSheet.Range("A3:Q200").RemoveDuplicates Columns:=Array(4, 5, 6), Header:=xlNo
        End If
        If rng.Offset(, 1) = "Yes" Then
            Sheets("Sheet1").Cells(rng.Row, 1).Resize(, 12).Copy Sheets("ASD PD").Cells(y, 1)
            y = y + 1
            ActiveSheet.Range("A3:Q200").RemoveDuplicates Columns:=Array(4, 5, 6), Header:=xlNo
        End If
    Next rng
    Application.ScreenUpdating = True
End If

End Sub

Answer 2

尝试一下：

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

  Set KeyCells = Range("K:L")

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

  Application.ScreenUpdating = False
  Dim LastRow As Long
  LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Dim x As Long
  x = 3
  Dim rng As Range
  For Each rng In Sheets("Sheet1").Range("K3:L" & LastRow)
      If rng = "Yes" Then
          Range("A" & rng.row & ":L" & rng.row).Copy Sheets("ASD 5P").Cells(x, 1)
          x = x + 1
          ActiveSheet.Range("A3:Q200").RemoveDuplicates Columns:=Array(4, 5, 6), Header:=xlNo
      End If
  Next rng
  Application.ScreenUpdating = True

  End If
  End Sub

将列A：L复制到另一个工作表（不是整个列）的VBA代码

2 个答案: