VBA to paste cell values into colored cells in table, then delete empty cells

Hi there,

I'm strugling to solve the following roadblock when utilizing VBA scripts.

I have a table with a set header and first 3 measurement columns. Cells which are relevant to me are colored grey (not the basic excel colorindex grey unfortunately).

I'd like to copy the header column's value into the colored cells (according to which column they are in of course), and then delete the empty, "non grey" cells and the header row. Leaving me with a list for every object which had an entry in that column.

If there is an other, simpler method, please feel free to let me know, I appreciate your help!

Step-by-step to what I'd like to accomplish

Input

Step 1

Step 2

Output

Edit - Code Update

Sub CreateDoc()


Dim rng As Range
Dim Col As Range
Dim Row As Range
Dim Cell As Range
Dim StatColor As Long


Set rng = Worksheets("Sheet1").Range("A2").CurrentRegion 'Dataset
StatColor = 14737632 'This is the bg color I'm looking for

'Replace Leg

For Each Col In rng.Columns 
    If Col.Column > 3 Then 'Skipping first 3 columns as they do not contain data, they are just headers
        For Each Cell In Col.Cells
            If Cell.Cells.Interior.color = StatColor Then
            Cell.Replace "", Col.Cells(1, 1).Value, xlPart 'replace 1 with 'top cell of each column
            End If
        Next Cell
    End If
Next Col

'Delete Leg

For Each Col In rng.Columns 
    If Col.Column > 3 Then
        For Each Cell In Col.Cells
            If Cell.Value = "" Then
            Col.Cells.Delete shift:=xlLeft
            End If
        Next Cell
    End If
Next Col
            

Set rng = Nothing
End Sub

Solution

Solved it via Claude

Sub DeleteNonGreyCells()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim lastRow As Long, lastCol As Long
    Dim greyColor As Long
    Dim col As Long, row As Long
    Dim dataWs As Worksheet
    
    ' Set the worksheets
    Set dataWs = ThisWorkbook.Worksheets("Input_Sheet")
    Set ws = ThisWorkbook.Worksheets("Result_Sheet")
    
    ' Copy data from Input Sheet to Result Sheet
    dataWs.Range("A2").CurrentRegion.Copy ws.Range("A1")
    
    ' Set the grey color
    greyColor = RGB(200, 200, 200) ' Light grey
    
    ' Find the last row and column with data
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Set the range to process
    Set rng = ws.Range(ws.Cells(2, 4), ws.Cells(lastRow, lastCol))
    
    ' Process grey cells
    For col = 4 To lastCol
        For Each cell In rng.Columns(col - 3).Cells
            If cell.Interior.Color = greyColor Then
                cell.Value = ws.Cells(1, col).Value
            End If
        Next cell
    Next col
    
    ' Delete non-grey cells and shift grey cells to the left
    Application.ScreenUpdating = False
    For row = 2 To lastRow
        For col = lastCol To 4 Step -1
            If ws.Cells(row, col).Interior.Color <> greyColor Then
                ws.Cells(row, col).Delete Shift:=xlToLeft
            End If
        Next col
    Next row
    
    ' Delete the first row (row 1)
    ws.Rows(1).Delete
    
    Application.ScreenUpdating = True
End Sub