简体   繁体   中英

VBA code to copy columns A:L only to another sheet (not entire column)

I have a spreadsheet where I enter a persons details in columns AJ and then indicate Yes in column K if he/she is referred for ASD 5P or column L for ASD PD. When I enter 'Yes' in one or both of those columns, I want to copy columns A:L of that row over to the relevant tab. I have the following code which copies the entire row over, but I want it to stop at column L. Here is the code I've been using (copied and adapted from various sites). Can anyone help me to amend this please?!? 这是我的电子表格的样子

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

Suggested re-write (too long to fit in the comments!). Am also not sure you need to remove duplicates in your loop, but have left in as not sure what it does.

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

Give this a try:

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

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM