Copy specific cells to separate worksheets upon 2 conditions [Solved/Closed]

Posts
12
Registration date
Friday May 15, 2015
Last seen
June 5, 2015
- - Latest reply: vcoolio
Posts
1236
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
March 1, 2019
- Jun 1, 2015 at 08:28 AM
Hello everyone,

vcoolio has kindly written me a script to copy and paste specific cells from Sheet1 to Sheet2 if ONE condition is met (ie "Yes" is entered in cell AA in Sheet1) as follows:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Columns("AA:AA")) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False

Dim lRow As Long

lRow = Range("A" & Rows.Count).End(xlUp).Row

Sheets("sheet1").Select

For Each cell In Range("AA2:AA" & lRow)
If cell.Value = "Yes" Then
If Cells(cell.Row, "A") = "" Then
Cells(cell.Row, "A") = " "
End If
If Cells(cell.Row, "G") = "" Then
Cells(cell.Row, "G") = " "
End If
If Cells(cell.Row, "J") = "" Then
Cells(cell.Row, "J") = " "
End If
End If
Next cell

For Each cell In Range("AA2:AA" & lRow)
If cell.Value = "Yes" Then
Cells(cell.Row, "A").Copy
Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(cell.Row, "G").Copy
Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Cells(cell.Row, "J").Copy
Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next cell

Sheets("Sheet2").Range("B1:D" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets("Sheet2").Select

End Sub

I just wondered if the above can be amended to add in a second condition: if "Yes" is entered in cell BB in Sheet1, the same set of cells will then be copied from Sheet1 to Sheet3 (but still keeping the previous condition ie Yes in cell AA will copy cells to Sheet2).

Thanks very much and await your advice (thanks vcoolio again for your previous script).

Felicia

See more 

2 replies

Posts
1236
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
March 1, 2019
220
0
Thank you
Hello again Felicia,

You could have continued this in your last thread. However, in a standard module, place the following code:-

Sub CopyIt()

Application.ScreenUpdating = False

Dim lRow As Long

lRow = Range("A" & Rows.Count).End(xlUp).Row
    
Sheets("sheet1").Select
For Each cell In Range("AA2:AA" & lRow)
      If cell.Value = "Yes" Then
      If Cells(cell.Row, "A") = "" Then
      Cells(cell.Row, "A") = " "
End If
      If Cells(cell.Row, "G") = "" Then
      Cells(cell.Row, "G") = " "
End If
      If Cells(cell.Row, "J") = "" Then
      Cells(cell.Row, "J") = " "
End If
End If
Next cell
    
Sheets("sheet1").Select
For Each cell In Range("BB2:BB" & lRow)
      If cell.Value = "Yes" Then
      If Cells(cell.Row, "A") = "" Then
      Cells(cell.Row, "A") = " "
End If
      If Cells(cell.Row, "G") = "" Then
      Cells(cell.Row, "G") = " "
End If
      If Cells(cell.Row, "J") = "" Then
      Cells(cell.Row, "J") = " "
End If
End If
Next cell
For I = 2 To lRow

      If Cells(i, 27).Value = "Yes" Then
      Range(Cells(i, 1), Cells(i, 1)).Copy Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
      Range(Cells(i, 7), Cells(i, 7)).Copy Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
      Range(Cells(i, 10), Cells(i, 10)).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
      End If
      
      If Cells(i, 54).Value = "Yes" Then
      Range(Cells(i, 1), Cells(i, 1)).Copy Sheets("Sheet3").Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
      Range(Cells(i, 7), Cells(i, 7)).Copy Sheets("Sheet3").Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
      Range(Cells(i, 10), Cells(i, 10)).Copy Sheets("Sheet3").Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
      End If
Next

Sheets("Sheet2").Range("B1:D" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
Sheets("Sheet3").Range("B1:D" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub


and in the sheet 1 module, place the following:-

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
CopyIt
End Sub


You should now be able to make "Yes" entries in sheet 1, Column AA to have the same cells as previous transferred to sheet 2 and "Yes" entries in sheet 1, Column BB to have the same cells transferred to sheet 3.

Following is the sample work book for your perusal:-

https://www.dropbox.com/s/9q8gi658t17n1hk/Fwong%286%29.xlsm?dl=0

I hope that this helps.

Cheerio,
vcoolio.
Fwong
Posts
12
Registration date
Friday May 15, 2015
Last seen
June 5, 2015
-
Thanks, vcoolio. It worked really well.

Thanks a million,
Felicia
Posts
1236
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
March 1, 2019
220
0
Thank you
Hello Felicia,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.