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
9
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