excelvba

Paste cell values into colored cells in table, then delete empty cells

I have a table with a set header and first 3 measurement columns. Relevant cells are colored grey (not the basic Excel colorindex grey).

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

What I'd like to accomplish

Input
Input

Step 1
Step 1

Step 2
Step2

Output
Output

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