Hervorhebung von Spalten basierend auf Variable Zelle Wert VBA

Question

Ich möchte die Spalten wie ein Balken basierend auf Zelle Wert automatisch hervorheben.

Eg. 3h -> 3 Spalten neben dem Wert mit einer Füllfarbe hervorheben und wie ein Balken umranden.

1h -> 1 Spalte neben dem Wert markieren.

1.5h -> markieren Sie eineinhalb Spalten und so weiter.

Ich versuchte mit diesem Code unten, es funktioniert, aber es markieren und fügen Sie nur Spalten in B1. Wenn ich den Bereich zu ganzen Spalten hinzufügen, funktionieren die Makros nicht.

`Sub TimingBars() 
If Range("B1").Value <= 0 Then Exit Sub 
With Range(Cells(1, 3), Cells(1, 2 + Range("B1"))).EntireColumn 
    .Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 
Range(Cells(1, 3), Cells(1, 2 + Range("B1"))).Interior.Color = vbBlue 

End With 
End Sub` 

Bitte helfen Sie Dank!

Answer 1

Wenn Sie die markierte Zelle begrenzen wollen:

Sub TimingBars() 
Dim i, BarLimit As Integer 
Dim Rg, RgBar As Range 
Set Rg = Range("B1:B100") 

For Each cell In Rg 
If cell.Value > 0 Then 

    Set RgBar = Range(Cells(cell.Row, cell.Column + 1), Cells(cell.Row, cell.Column + cell.Value)) 
    RgBar.Interior.Color = vbBlue 
    With RgBar.Borders(xlEdgeLeft) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlThin 
    End With 
    With RgBar.Borders(xlEdgeTop) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlThin 
    End With 
    With RgBar.Borders(xlEdgeBottom) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlThin 
    End With 
    With RgBar.Borders(xlEdgeRight) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
    End With 
    End If 

Next cell 
End Sub 

Answer 2

Bitte versuchen Sie dies:

Sub TimingBars() 
Dim i, BarLimit As Integer 
Dim Rg As Range 
Set Rg = Range("B1:B100") ' change this range as you want 

For Each cell In Rg 
    For i = 1 To cell.Value Step 1 
    Cells(cell.Row, cell.Column + i).Interior.Color = vbBlue 
    Next i 
Next cell 
End Sub