Previous Topic Next Topic

Copy specific cells to separate worksheets upon 2 conditions

Solved/Closed
Fwong Posts 11 Registration date Friday May 15, 2015 Status Member Last seen June 5, 2015 - May 30, 2015 at 06:13 PM
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 - 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

Related:

2 responses

Answer 1 / 2
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 262
Jun 1, 2015 at 04:49 AM
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.
0
Fwong Posts 11 Registration date Friday May 15, 2015 Status Member Last seen June 5, 2015
Jun 1, 2015 at 07:38 AM
Thanks, vcoolio. It worked really well.

Thanks a million,
Felicia
0
Answer 2 / 2
vcoolio Posts 1411 Registration date Thursday July 24, 2014 Status Moderator Last seen September 6, 2024 262
Jun 1, 2015 at 08:28 AM
Hello Felicia,

You're welcome. Glad that I could help.

Cheerio,
vcoolio.
0