Search code examples
excelvbahighlightstring-length

Highlight cells as a function of string length

I have a situation where the user imports a file, and the file name/location are printed to cell A1. As it stands, the highlighted cells are hard coded.

'Retreive File Name
 Worksheets("Header_Info").Range("A1") = Ret
 Worksheets("Header_Info").Range("A1:K1").Interior.Color = RGB(255, 255, 0)

In some situations, the file name/location length exceeds the highlighted cells. I would like to make this more dynamic and have the highlighted cells become a function of the length of the file name/location string.

File name/location

I've attempted to determine the last column used, but this does not work, as the entire text remains in cell A1 and is superimposed on the adjacent cells, not actually filling them.

Option Explicit
Sub HighlightString()
'This macro will highlight the number of cells as a function of the string length

    Dim rng As Range
    Dim strLength As Long
    Dim cond1 As FormatConditions

    Set rng = Range("A1", Range("A1").End(xlToLeft))

    'clear any existing conditional formatting
    rng.FormatConditions.Delete

    strLength = Len(Range("A1"))

    'Conditional Rules
    Set cond1 = rng.FormatCondition.Add(xlCellValue, xlEqual, strLength)

    'Apply Condition
    With cond1
    .Interior.Color = vbYellow
    End With

End Sub

With this, I'm getting a run-time error '438' probably because strLength is not supported in this context. How can I overcome this?

Solution

  • Try the next approach, please. It uses a trick: Copy the range to be fit two columns over the used range, auto fit the column, uses its ColumnWidth to make the adjustment and finally clear the temporary cell:

    Sub testMatchOnlyACellWidth()
 Dim sh As Worksheet, lastEmptyCol As Long
 Set sh = ActiveSheet
 lastEmptyCol = sh.UsedRange.Columns.count + 2
 sh.Range("A1").Copy sh.Cells(1, lastEmptyCol)
 sh.Cells(1, lastEmptyCol).EntireColumn.AutoFit

 sh.Range("A1").ColumnWidth = sh.Cells(1, lastEmptyCol).ColumnWidth
 sh.Cells(1, lastEmptyCol).Clear
End Sub

    To fit at the header text length all cells from range "A1:K1", use the next code, please:

    Sub testMatchCellsWidth()
 Dim sh As Worksheet, lastEmptyCol As Long, i As Long
 Set sh = Worksheets("Header_Info")
 lastEmptyCol = sh.UsedRange.Columns.Count + 2
 sh.Range("A1:K1").Copy sh.Cells(1, lastEmptyCol)
 sh.Range(sh.Cells(1, lastEmptyCol), sh.Cells(1, lastEmptyCol + 10)).EntireColumn.AutoFit
 Stop
 Debug.Print sh.Cells(1, lastEmptyCol + 1 - 1).address
 For i = 1 To 11
    sh.Cells(1, i).ColumnWidth = sh.Cells(1, lastEmptyCol - 1 + i).ColumnWidth
    sh.Cells(1, i).Interior.Color = RGB(255, 255, 0)
    sh.Cells(1, lastEmptyCol - 1 + i).Clear
 Next i
End Sub