Need help converting macro from horizontal to vertical coloring

Question

I need some help transforming an existing code to color cells based on a value horizontally to vertically.

I've been trying all kinds of things but I can't figure out on how to edit the code to work vertically. The first picture is the existing horizontal coloring which works great, the second picture is how I need to coloring to be done.

Anyone who can help me in the right direction? I do have a testfile that I can share with all the sheets. The code basically gets the colors and location out of different sheets but this is working / ok. The 3th pictures is a screenshot of the ranges tab with how the ranges are set up for the query.

Existing Plan:

New Plan:

Ranges Tab:

My code:

'Sheet renamers
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets("Plan")
Dim queryws As Worksheet
Set queryws = wb.Worksheets("Query")
queryws.AutoFilterMode = False
Dim colorws As Worksheet
Set colorws = wb.Worksheets("Colors")
colorws.AutoFilterMode = False
Dim rangews As Worksheet
Set rangews = wb.Worksheets("Ranges")
rangews.AutoFilterMode = False
lr = rangews.Range("A1000").End(xlUp).Row

'Remove colors from each block
For i = 2 To lr
LocAddress = rangews.Range("D" & i).Value
ws.Range(LocAddress).Interior.Color = 16777215
Next i

'Run through query
lrquery = queryws.Range("A100000").End(xlUp).Row
queryws.UsedRange.AutoFilter Field:=40, Criteria1:="Location"
For Each c In queryws.UsedRange.Offset(1, 0).Resize(lrquery - 1).Columns(11).SpecialCells(xlCellTypeVisible).Cells
blok = Left(c.Value, 3)
CombinedAddress = Application.WorksheetFunction.VLookup(blok, rangews.Range("A:E"), 5, False)
BeginRow = Application.WorksheetFunction.VLookup(blok, rangews.Range("A:G"), 6, False)
EndRow = Application.WorksheetFunction.VLookup(blok, rangews.Range("A:G"), 7, False)
BeginColumn = Application.WorksheetFunction.VLookup(blok, rangews.Range("A:H"), 8, False)
Disc1 = c.Offset(0, -10).Value
If Disc1 <> "" Then
On Error Resume Next
kleur = 0
kleur = Application.WorksheetFunction.VLookup(Disc1, colorws.Range("A:C"), 3, False)
If kleur = 0 Then
MsgBox ("Please add " & Disc1)
Exit Sub
End If
On Error GoTo 0
Else
kleur = 65535
End If
Set R1 = ws.Range(CombinedAddress)
Sublocation = Right(c.Value, 2)
kolominrange = Application.WorksheetFunction.Match(CLng(Sublocation), R1)
kolominws = BeginColumn + kolominrange - 1

'Coloring
For Each c3 In ws.Range(ws.Cells(BeginRow, kolominws), ws.Cells(EndRow, kolominws))
If c3.Interior.Color = 16777215 And c3.MergeCells = False Then
c3.Interior.Color = kleur
c.Interior.Color = kleur
Exit For
End If
Next c3
Next c