Worksheet Loop searching for yellow

[sscornav]

Any help would be appreciated, this is beyond my capabilities.

I need to loop through all of the worksheets in a workbook ( I could also but all of the worksheet names in a named range) and copy any rows that have any yellow highlight in them. They should be copied into a separate worksheet called "XXX"

Thanks!

 

[Domenic]

The following macro will loop through each worksheet within the active workbook, except the worksheet called "XXX", and copy any row that has a cell highlighted in yellow to your worksheet called "XXX". Note that there's no error handling, so it assumes that your worksheet called "XXX" already exists.

Option Explicit

Sub CopyHighlightedRows()


    Dim destinationWorksheet As Worksheet
    Dim currentWorksheet As Worksheet
    Dim currentRow As Range
    Dim currentCell As Range
    
    Set destinationWorksheet = Worksheets("XXX")
    
    destinationWorksheet.Cells.Clear
    
    For Each currentWorksheet In ActiveWorkbook.Worksheets
        If currentWorksheet.Name <> destinationWorksheet.Name Then
            For Each currentRow In currentWorksheet.UsedRange.Rows
                For Each currentCell In currentRow.Cells
                    If currentCell.Interior.Color = vbYellow Then
                        With destinationWorksheet
                            currentRow.Copy .Cells(.Rows.Count, "a").End(xlUp)(2)
                            Exit For
                        End With
                    End If
                Next currentCell
            Next currentRow
        End If
    Next currentWorksheet
    
    destinationWorksheet.Activate
    
End Sub

Hope this helps!

 

[sscornav]

Thanks Domenic! I will give it a try and report back. I really appreciate the assistance!

 

[sscornav]

Worked great...I forgot about other cells that might be highlighted yellow.

What if I wanted to check for the contents of a cell to contain "XYZ", then copy it.

How do you say "if this cell contains XYZ then " ?

 

[Domenic]

To check whether a cell contains "XYZ", try...

If InStr(1, currentCell.Value, "XYZ", vbTextCompare) > 0 Then

To check whether a cell contains "XYZ" and is highlighted in yellow, try...

If InStr(1, currentCell.Value, "XYZ", vbTextCompare) > 0 _
    And currentCell.Interior.Color = vbYellow Then

Note that the comparison is not case-sensitive. For a case-sensitive comparison, replace vbTextCompare with vbBinaryCompare.

 

[sscornav]

Although when I was just checking yellow, it seemed to work, now there are 2 issues.

1)It doesn't handle cells that have N/A or Div/0 in them. It has an exception on the InStr line. Can this be made more bulletproof?
2) After the exception, when I look in the XXX file, there is only one line in it and it seems to be the last one. It was working when it was looking for color. Thinking maybe this a a result of the VBA exception??

 

[sscornav]

I added an IsError function to the if statement to skipp over the NA and Div/0 cells and it seems to work

There is still a problem with the following statement:
currentRow.Copy .Cells(.Rows.Count, "a").End(xlUp)(2)

Instead of appending on to the end, it seems to be overwriting. I put a MsgBox function in the If statement and it is evaluating correctly, but the copy is not working.

Thanks, Steve

 

[sscornav]

I think I found the issue.... not every row we are copying has data in column A, so those rows are getting overwritten by subsequent copies.

Is there something we could use instead of:
currentRow.Copy .Cells(.Rows.Count, "a").End(xlUp)(2)
That will just append the copied row onto the end, regardless of whether there is data in column A?

 

[Domenic]

Try...

Option Explicit

Sub CopyRows()


    Dim destinationWorksheet As Worksheet
    Dim currentWorksheet As Worksheet
    Dim currentRow As Range
    Dim currentCell As Range
    Dim rowNumber As Long
    
    Set destinationWorksheet = Worksheets("XXX")
    
    destinationWorksheet.Cells.Clear
    
    rowNumber = 2 'start to paste at Row 2
    For Each currentWorksheet In ActiveWorkbook.Worksheets
        If currentWorksheet.Name <> destinationWorksheet.Name Then
            For Each currentRow In currentWorksheet.UsedRange.Rows
                For Each currentCell In currentRow.Cells
                    If Not IsError(currentCell) Then
                        If InStr(1, currentCell.Value, "XYZ", vbTextCompare) > 0 Then
                            If currentCell.Interior.Color = vbYellow Then
                                currentRow.Copy destinationWorksheet.Cells(rowNumber, "a")
                                rowNumber = rowNumber + 1
                                Exit For
                            End If
                        End If
                    End If
                Next currentCell
            Next currentRow
        End If
    Next currentWorksheet
    
    destinationWorksheet.Activate
    
End Sub

 

[sscornav]

Perfect...thanks! Learned quite a bit from this!