Search color than search value than copy both rows

[emukiss10]

Hello Guys!

A little tricky VBA request.

first part of code looks like this: (if cells have interior color diff than white add "NO" to selected row to column L)

 Dim CColour As Long
 Dim e As Long


    CColour = RGB(255, 255, 255)
    
    For e = 2 To Cells(Rows.count, "A").End(xlUp).row
        If Cells(e, "E").Interior.Color <> CColour Then
[B]        Cells(e, "L") = "NO"[/B]
        End If
    Next e

I would like to delete that Bold statement and add complicated one.

if color <> white then

take number from cell A2 Sheets(2) (if in row 2 col E color do not match ofc),
search it in cell column A Sheets(6)
and if found copy entire row Sheets(6) to Sheets(7) (Sheets(7) has headers so start from row 2)
and the row A2 Sheets(2) to next row Sheets(7)
- add one blank row (with no data for estetics) and go on till end of data in column A Sheets(2)





--------------------------------
Mayby this code can be of some use (copyright FLUFF)

   Dim Cl As Range
   Dim rng As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sheets(1).Range("F2", Sheets(1).Range("F" & Rows.count).End(xlUp))
         If Not .Exists(Cl.Value) Then .Add Cl.Value, Nothing
      Next Cl
      For Each Cl In Sheets(2).Range("E2", Sheets(2).Range("E" & Rows.count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            If rng Is Nothing Then
               Set rng = Cl
            Else
               Set rng = Union(rng, Cl)
            End If
         End If
      Next Cl
   End With
   If Not rng Is Nothing Then rng.EntireRow.Delete

Best Regards
W.

 

[Fluff]

How about

Sub CopyRowsBasedOnColour()

   Dim Cl As Range
   Dim Ws2 As Worksheet
   Dim Ws6 As Worksheet
   Dim Ws7 As Worksheet
   
   Set Ws2 = Sheets("Sheet2")
   Set Ws6 = Sheets("Sheet6")
   Set Ws7 = Sheets("Sheet7")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("E2", Ws2.Range("E" & Rows.Count).End(xlUp))
         If Not Cl.Interior.Color = RGB(255, 255, 255) Then
            If Not .exists(Cl.Offset(, -4).Value) Then .Add Cl.Offset(, -4).Value, Cl.Offset(, -4)
         End If
      Next Cl
      For Each Cl In Ws6.Range("A2", Ws6.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            Cl.EntireRow.Copy Ws7.Range("A" & Rows.Count).End(xlUp).Offset(2)
            .Item(Cl.Value).EntireRow.Copy Ws7.Range("A" & Rows.Count).End(xlUp).Offset(1)
         End If
      Next Cl
   End With

End Sub

 

[emukiss10]

Hello Fluff,

It works but only for unique values in col A.

A E F and so on

1 white Different data in every column

2 white Different data in every column

3 white Different data in every column

4 white Different data in every column

5 white Different data in every column

6 white Different data in every column

7 Blue Different data in every column

7 Blue Different data in every column

8 white Different data in every column

9 white Different data in every column

10 white Different data in every column

It copy only first "7" to the final sheet. (the rest is working correctly)

 

[Fluff]

What do you want to happen, when the value in col A is repeated?

 

[emukiss10]

copy it like all the others. The value in col A may be the same but the rest of the values, rest of the columns are different.

 

[Fluff]

Do you want to copy sheet 6 for each duplicate in sheet2, or just copy sheet6 once with all the sheet2 values underneath?

 

[emukiss10]

Copy duplicate. It is for visual verification and dthe data may be totally different. Please

 

[Fluff]

But do you want it to look like this

Excel 2013 32 bit
	A	B
1	title1	title 2
2	sheet6	row x
3	sheet2	row a
4	sheet2	row b
5	sheet2	row c
6
7	sheet6	row x
8	sheet2	row a
9	sheet2	row b
10	sheet2	row c
Sheet7

Or like this

Excel 2013 32 bit
	A	B
1	title1	title 2
2	sheet6	row x
3	sheet2	row a
4
5	sheet6	row x
6	sheet2	row b
7
8	sheet6	row x
9	sheet2	row c
10
11	sheet6	row x
12	sheet2	row a
Sheet7

 

[emukiss10]

Second idea.

2 rows, blank, 2 rows, blank etc.

 

[Fluff]

How about

Sub CopyRowsBasedOnColour()

   Dim Cl As Range
   Dim Cnt As Long
   Dim Adrs As Variant
   Dim Ws2 As Worksheet
   Dim Ws6 As Worksheet
   Dim Ws7 As Worksheet
   
   Set Ws2 = Sheets("Sheet2")
   Set Ws6 = Sheets("Sheet6")
   Set Ws7 = Sheets("Sheet7")
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Ws2.Range("E2", Ws2.Range("E" & Rows.Count).End(xlUp))
         If Not Cl.Interior.Color = RGB(255, 255, 255) Then
            If Not .exists(Cl.Offset(, -4).Value) Then
               .Add Cl.Offset(, -4).Value, Cl.Offset(, -4).Address
            Else
               .Item(Cl.Offset(, -4).Value) = .Item(Cl.Offset(, -4).Value) & "," & Cl.Offset(, -4).Address
            End If
         End If
      Next Cl
      For Each Cl In Ws6.Range("A2", Ws6.Range("A" & Rows.Count).End(xlUp))
         If .exists(Cl.Value) Then
            Adrs = Split(.Item(Cl.Value), ",")
            For Cnt = LBound(Adrs) To UBound(Adrs)
               Cl.EntireRow.Copy Ws7.Range("A" & Rows.Count).End(xlUp).Offset(2)
               Ws2.Range(Adrs(Cnt)).EntireRow.Copy Ws7.Range("A" & Rows.Count).End(xlUp).Offset(1)
            Next Cnt
         End If
      Next Cl
   End With

End Sub