If Cell is Highlighted -> Copy Row and Paste in Sheet2

[CC268]

This should be pretty easy...I need a VBA code that will go down Column B and look for highlighted cells (vbYellow). If it is highlighted I need it to copy that entire row and paste it into Sheet1. Here is the tricky part. There is already several thousand lines of data in Sheet1 so the code will need to find out what the last line is in Sheet1 so it can paste below the last row of data.

[SamT]

If Conditional Formatting to highlight, its a whole differnt story

Manual or by code highlighting

If Cell.Interior.Color = vbYellow, Then 'Cell is Highlighted

Finding the next empty Row requires knowing whch Column always has a value. Assuming this is Column B

NextEmptyRowNumber = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row + 1

[CC268]

I guess I should have been a little more clear on everything. So I have a macro (seen below) that goes through columns A and B and highlights which numbers in column B aren't in column A. Now I need a code that will go find the numbers highlighted in column B and then copy the entire row and paste it into Sheet1. There is already a few thousand lines of data in Sheet 1 so if Sheet 1 contains 2001 rows of data I need it to copy the data into row 2002. Does that make sense?

Here is the code I used for highlighting.

Sub FindRows()  
  Dim cell As Range
  
  For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp))
    If Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then cell.Interior.Color = vbYellow
  Next cell
  
End Sub

I will see what I can do with the two lines of code you provided. How do I get it to copy and paste that highlighted row now?

[SamT]

For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp)) 
        If cell.Interior.Color = vbYellow Then cell.EntireRow.Copy _
          Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, -1)
Next

[CC268]

Nice! I apologize but I forgot to mention that I need it to EXCLUDE row A when it copies and pulls the data over. I also need to it to paste the data starting in column M and not A. Sorry to throw a wrench in this I just realized this. Can we do something like that?

[SamT]

For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp)) 
    If cell.Interior.Color = vbYellow Then _
    Intersect(UsedRange,  cell.EntireRow).Offset(,1).Copy _ 
    Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 11) 
Next

In one pass:

Sub FindAndCopyRows() 
    Dim cell As Range 
     
    For Each cell In Range("B2", Cells(Rows.Count, "B").End(xlUp)) 
        If Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then _
    Intersect(UsedRange,  cell.EntireRow).Offset(,1).Copy _ 
    Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(1, 11)
    Next cell 
     
End Sub

[CC268]

Hmm..it isn't liking that. It is saying Object Required and then highlighting the last two lines of code (Intersect and Sheet lines).

[CC268]

There are two worksheets sheet 2 and sheet 1. sheet 2 contains the highlighted cells in column B. I need to find those highlighted cells in column b, copy the row (EXCEPT for column A) and then paste them into Sheet1, starting at column M.

[SamT]

Try putting the For loop in a With Sheets("Sheet2") block, then putting a Dot (.) in front of each "Range" and "UsedRange" The dots will assign those ranges to the With Object (sheet 2.)

Sub FindAndCopyRows()
    Dim cell As Range
    
   'Application.ScreenUpdating = False 'Uncomment after testing

    With Sheets("Sheet2")
    For Each cell In .Range("B2", Cells(Rows.Count, "B").End(xlUp))
        If .Range("A:A").Find(What:=cell.Value2, LookAt:=xlWhole) Is Nothing Then _
        Intersect(.UsedRange, cell.EntireRow).Offset(, 1).Copy _
        Sheets("Sheet1").Cells(Rows.Count, "M").End(xlUp).Offset(1) '<<< note change
    Next cell
     End With

Application.ScreenUpdating = True
End Sub

This is not the way I would do it, but I don't know what your data structure is, what other preparatory actions you've taken, and what the final requirements are.

[CC268]

Thanks that worked beautifully!!