VBA - Document particular cells Value, Address and Heading to new sheet

[Anbuselvam]

Dear All

Find the below dropbox linked sheet, In that, I want to find the yellow-coloured cells and it must be documented to the new sheet with its value, cell address and the Heading of the same.

For that, I tried below code and I got error 438

Dropbox - File Deleted - Simplify your life

www.dropbox.com

Note: Similar question posted in chandoo.org and the link is below for your information

VBA - Document particular cells value, address and heading to New Sheet

Dear All Find the attached sheet, In that, I want to find the yellow-coloured cells and it must be documented to the new sheet with its value and cell address. For that, I tried below code and I got error 438 Option Explicit Sub SelectColoredCells() Dim Sh As Worksheet Dim rCell As...

chandoo.org

Option Explicit

Sub SelectColoredCells()
    Dim Sh As Worksheet
    Dim rCell As Range, PDate As Range
    Dim lColor As Long, r As Long
    Dim rColored As Range
    Dim High As Date
    
    Application.ScreenUpdating = False
    ' Create a new sheet
    Set Sh = Worksheets.Add
    lColor = RGB(255, 255, 0)

    Set rColored = Nothing
    For Each rCell In Sheet9.Range("A7:BD800")
        If rCell.Interior.Color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
            End If
        End If
    Next
If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
 With Sh
        'Put header "Comment", "Address" & "Author" in A1, B1 & C1 respectively.
        .Cells(1, 1).Value = "Value"
        .Cells(1, 2).Value = "Cell Address"
    r = 2
        For Each rColored In Sheet9
            .Cells(r, 1).Value = rColored.Value
            .Cells(r, 2).Value = rColored.Parent.Address
            r = r + 1
        Next rColored
        .Columns.AutoFit
End With
End If
End Sub

 

[Fluff]

How about

 With Sh
        
        .Cells(1, 1).Resize(, 3).Value = Array("Value", "Cell Address", "Heading")
    r = 2
        For Each rCell In rColored
            .Cells(r, 1).Value = rCell.Value
            .Cells(r, 2).Value = rCell.Address(0, 0)
            .Cells(r, 3).Value = Sheet1.Cells(6, rCell.Column)
            r = r + 1
        Next rCell
        .Columns.AutoFit
End With

 

[Anbuselvam]

Dear Fluff

Thanks for your suggestion. it is working perfectly.

 

[Fluff]

You're welcome & thanks for the feedback