将单元格突出显示为字符串长度的函数

Question

我有这样一种情况，用户导入文件，文件 name/location 被打印到单元格 A1。目前，突出显示的单元格是硬编码的。

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

在某些情况下，文件 name/location 长度超过突出显示的单元格。我想让它更具动态性，并让突出显示的单元格成为文件 name/location 字符串长度的函数。

我试图确定使用的最后一列，但这不起作用，因为整个文本保留在单元格 A1 中并叠加在相邻单元格上，而不是实际填充它们。

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

有了这个，我得到了运行时间错误“438”，可能是因为在此上下文中不支持 strLength。我该如何克服这个问题？

Answer 1

请尝试下一种方法。它使用了一个技巧：将要适应的范围复制到已使用范围的两列，自动适应该列，使用其 ColumnWidth 进行调整，最后清除临时单元格：

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

要适应 header 文本长度 范围“A1:K1”中的所有单元格，请使用下一个代码：

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

Answer 2

由未知用户修改...

Sub HighlightString()

    'Supress Active Screen Updating
    Application.ScreenUpdating = False
    
    ' Storing initial values somewhere else
    For i = 1 To 1
        Worksheets("Sheet1").Cells(i, 2) = Worksheets("Sheet1").Cells(i, 1)
        Worksheets("Sheet1").Cells(i, 1) = ""
    Next

    For i = 1 To 1
        Worksheets("Sheet1").Cells(i, 1) = Worksheets("Sheet1").Cells(i, 2)

        actual = 0

        ' Calculate the cell width
        If Worksheets("Sheet1").Cells(i, 1) <> "" Then
            back = Columns(1).EntireColumn.ColumnWidth
            Columns(1).EntireColumn.AutoFit
            actual = Columns(1).EntireColumn.ColumnWidth
            Columns(1).EntireColumn.ColumnWidth = back
        End If

        col = 1
        While actual > 0
            Worksheets("Sheet1").Cells(i, col).Interior.Color = RGB(255, 255, 0)
    
            actual = actual - Columns(col).EntireColumn.ColumnWidth
            col = col + 1
        Wend

        Worksheets("Sheet1").Cells(i, 1) = ""
    Next

    ' Restoring initial values
    For i = 1 To 1
    Worksheets("Sheet1").Cells(i, 1) = Worksheets("Sheet1").Cells(i, 2)
        Worksheets("Sheet1").Cells(i, 2) = ""
    Next

    'Allow Active Screen Updating
    Application.ScreenUpdating = True


End Sub

符合预期目的。

将单元格突出显示为字符串长度的函数

Highlight cells as a function of string length

excel

vba

highlight

string-length