Continuous cell colouring

[Danny King]

Hi all,

I am hoping some one can fix my broken VBA,

Sub ColorCellsBasedOnCriteria()
    Dim engineSheet As Worksheet
    Dim powSheet As Worksheet
    Dim totalCells As Integer
    Dim maxCellsPerColumn As Integer
    Dim currentRow As Integer
    Dim currentColumn As Integer
    Dim cellsColored As Integer
   
    Set engineSheet = ThisWorkbook.Sheets("Engine")
    Set powSheet = ThisWorkbook.Sheets("PoW")
    
    totalCells = engineSheet.Range("B3").Value
    maxCellsPerColumn = engineSheet.Range("B6").Value
    
    maxCellsPerColumn = Application.WorksheetFunction.Min(maxCellsPerColumn, powSheet.Cells(7, powSheet.Columns.count).End(xlToLeft).column - 2)
    
    For currentColumn = 3 To 2 + maxCellsPerColumn
        If powSheet.Cells(7, currentColumn).Value = "Y" Then
            currentRow = engineSheet.Cells(8 + currentColumn - 2, 3).Value
            cellsColored = 0
            
            Do While currentRow <= powSheet.Rows.count And cellsColored < totalCells And cellsColored < maxCellsPerColumn
                powSheet.Cells(currentRow, currentColumn).Interior.Color = RGB(173, 216, 230)
                cellsColored = cellsColored + 1
                currentRow = currentRow + 1
            Loop
        End If
    Next currentColumn
End Sub

What I am trying to achieve is on my "Engine" sheet I have total amount of cells I need colouring (B3) and in (B6) what I need the maximum coloured cells per column to be. On my "PoW" sheet (where I want the colouring to take place) in row 7 there are random Y`s, so I want it to look along row seven if there is a Y colour the maximum amount of cells allowed without exceeding the total amount. This I managed to achieve but the complicated part that is not working is that I want the colouring to start on different rows, I want it to be a continuous cycle excluding columns without a Y in it, I did get it to reference row numbers on the "Engine" sheet (C9, C10, C11.........) but this is breaking it. Its ok if the columns are continuous but if there is a break the colouring aspect breaks,

So for context if I had 28 as the total amount and the maximum as 3, I would want it to colour 3 for column every column till 28 cells are coloured. Apologies might have been a far easier way to explain it

 

[Joe4]

Welcome to the Board!

Here is code that I came up with:

Sub ColorCells()

    Dim lc As Long
    Dim c As Long
    Dim n As Long
    Dim fr As Long
    Dim lr As Long
    
    Application.ScreenUpdating = False
    
'   Find last column in column 7 with data
    lc = Cells(7, Columns.Count).End(xlToLeft).Column
    
'   Loop through all columns
    For c = 1 To lc
'       See if current cell is "Y"
        If Cells(7, c) = "Y" Then
'           Add one to count
            n = n + 1
'           Calculate first and last rows
            fr = n * 3 + 5
            lr = n * 3 + 7
'           Color cells
            Range(Cells(fr, c), Cells(lr, c)).Interior.Color = RGB(173, 216, 230)
        End If
    Next c
    
    Application.ScreenUpdating = True
    
    MsgBox "Macro complete!"
    
End Sub

And here are the results: