VBA copy and paste yellow highlighted row

[Nani520]

Hi,

Appreciate if anyone can assist to create a macro to copy yellow highlighted and selected column (in this case B, D, F) in Sheet1 and paste into Sheet2.
Any help is most appreciated! Thanks in advance.

Sheet 1

Result in Sheet 2

 

[Trebor76]

Hi Nani520,

As the as the entire row is filled yellow and its fill is not from a Conditional Formatting rule, this will do the job:

Option Explicit
Sub Macro1()

    Dim i As Long, j As Long
    Dim wsFrom As Worksheet, wsTo As Worksheet
   
    Application.ScreenUpdating = False
   
    Set wsFrom = ThisWorkbook.Sheets("Sheet1")
    Set wsTo = ThisWorkbook.Sheets("Sheet2")
   
    On Error Resume Next
        j = wsTo.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        j = IIf(j = 0, 2, j + 1)
    On Error GoTo 0
   
    For i = 7 To wsFrom.Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        If wsFrom.Rows(i).Interior.Color = 65535 Then
            wsTo.Range("A" & j).Value = wsFrom.Range("B" & i).Value
            wsTo.Range("B" & j).Value = wsFrom.Range("D" & i).Value
            wsTo.Range("C" & j).Value = wsFrom.Range("F" & i).Value
            j = j + 1
        End If
    Next i
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

You could also target the yellow cells more directly, rather than checking every row, and also transfer all three cells at once for each yellow row as follows

Sub Copy_Yellow()
  Dim Firstrow As Long
  Dim rFound As Range
  
  With Application.FindFormat
    .Clear
    .Interior.Color = vbYellow
  End With
  With Sheets("Sheet1").Columns("B")
    Set rFound = .Find(What:="*", SearchDirection:=xlNext, SearchFormat:=True)
    If Not rFound Is Nothing Then
      Firstrow = rFound.Row
      Do
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Array(rFound, rFound.Offset(, 2), rFound.Offset(, 4))
        Set rFound = .Find(What:="*", after:=rFound, SearchDirection:=xlNext, SearchFormat:=True)
      Loop Until rFound.Row = Firstrow
    End If
  End With
  Application.FindFormat.Clear
End Sub

 

[Nani520]

Thanks

You could also target the yellow cells more directly, rather than checking every row, and also transfer all three cells at once for each yellow row as follows

Sub Copy_Yellow()
  Dim Firstrow As Long
  Dim rFound As Range
 
  With Application.FindFormat
    .Clear
    .Interior.Color = vbYellow
  End With
  With Sheets("Sheet1").Columns("B")
    Set rFound = .Find(What:="*", SearchDirection:=xlNext, SearchFormat:=True)
    If Not rFound Is Nothing Then
      Firstrow = rFound.Row
      Do
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 3).Value = Array(rFound, rFound.Offset(, 2), rFound.Offset(, 4))
        Set rFound = .Find(What:="*", after:=rFound, SearchDirection:=xlNext, SearchFormat:=True)
      Loop Until rFound.Row = Firstrow
    End If
  End With
  Application.FindFormat.Clear
End Sub

Thank you so much!!!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

 

[Rick Rothstein]

You can also do what you asked for without using any loops...

Sub CopyYellowRowsColsBDF()
  Dim FirstUnusedCol As String, CopyCols As String
  FirstUnusedCol = "G"
  CopyCols = "B:B,D:D,F:F"
  Application.FindFormat.Clear
  Application.FindFormat.Interior.Color = vbYellow
  With Sheets("Sheet1")
    .Columns(FirstUnusedCol).Replace "", "X", xlWhole, , , , True, False
    Application.FindFormat.Clear
    Intersect(.Range(CopyCols), .Columns(FirstUnusedCol).SpecialCells(xlConstants).EntireRow).Copy Sheets("Sheet2").Range("A2")
    Sheets("Sheet2").Range("A2").CurrentRegion.Interior.ColorIndex = xlNone
    .Columns("G").ClearContents
  End With
End Sub