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.