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

Question

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

Configuration: Windows 7 / Mozilla 11.0

vcoolio · Answer

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.

vcoolio · Answer

Hello Felicia,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.

Copy specific cells to separate worksheets upon 2 conditions

2 responses

Similar discussions

Subscribe To Our Newsletter!