Excel宏需求：列宽缩小时临时显示通用值，展开后恢复原值

问题背景 #

我有一个许可证编号跟踪工作表，列标题包含州名（如AK、AL、AR），每个州名后对应颁发日期（Issued）和过期日期（Expired）列，例如：AL | Al Issued | Al Expired。默认视图下州名列宽设为5，日期列隐藏，但客户行中的许可证编号过长，无法适配5列宽的单元格，会溢出列边界导致显示混乱。需要实现：

• 列宽为5时，州许可证编号显示为##（或其他通用标识，也可设置颜色）
• 列宽扩展为13时，显示真实值

现有HideStates和UnhideStates子过程，但存在两个问题：

1. 仅选中区域的第一个单元格显示###，后续单元格无变化
2. 替换操作是永久性的，列宽展开后无法恢复真实值

现有代码 #

Sub HideStates()
Dim lc As Long
Dim i As Long
Dim WS As Worksheet
Dim dRng As Range

Set WS = Worksheets("License Details")
lc = Range("A5").End(xlToRight).Column
lr = Range("A6").End(xlDown).row


For i = 6 To lc
row = 6

    If WS.Cells(5, i).Value Like "*Issued*" Or WS.Cells(5, i).Value Like "*Expires*" Then
    
        If WS.Cells(5, i).Value Like "*Issued*" Then
     
            WS.Cells(5, i - 1).ColumnWidth = 5
     
            WS.Range(Cells(row, i - 1), Cells(lr, i - 1)).Select
            
                For Each cell In Selection
                    If Cells(row, i - 1).Value <> "" Then
                    ActiveCell = Replace("###", "*", 1)
                    End If
                    row = row + 1
                Next cell
        
        End If
          
     If WS.Cells(5, i - 1).Value Like "**SPL*" Then WS.Cells(5, i - 1).ColumnWidth = 6

            If dRng Is Nothing Then
            Set dRng = WS.Cells(1, i)
        Else
            Set dRng = Union(dRng, WS.Cells(1, i))
        End If
    End If
Next i
If Not dRng Is Nothing Then
    dRng.EntireColumn.Hidden = True
    
    Call ScrollToTop 
End If
End Sub

Sub UnhideStates()
Dim lc As Long
Dim i As Long
Dim WS As Worksheet
Dim dRng As Range

Set WS = Worksheets("License Details")

For i = 6 To 164
    If WS.Cells(5, i).Value Like "*Issued*" Or WS.Cells(5, i).Value Like "*Expires*" Then
    
     If WS.Cells(5, i).Value Like "*Issued*" Then WS.Cells(5, i - 1).ColumnWidth = 13 
     
        If dRng Is Nothing Then
            Set dRng = WS.Cells(1, i)
        Else
            Set dRng = Union(dRng, WS.Cells(1, i))
        End If
    End If
Next i

If Not dRng Is Nothing Then
    dRng.EntireColumn.ColumnWidth = 13
    Call ScrollToTop 

End If
End Sub

问题原因分析 #

1. 仅第一个单元格生效：循环中错误使用ActiveCell和Cells(row, i-1)，没有引用当前遍历的cell对象，导致只有选中区域的第一个单元格被修改。
2. 永久性替换：直接修改单元格的值，覆盖了原始许可证编号，无法恢复。正确做法是通过单元格格式设置临时显示替代标识，保留原始数据。

修正后的代码 #

HideStates 子过程 #

Sub HideStates()
    Dim lc As Long
    Dim i As Long
    Dim WS As Worksheet
    Dim dRng As Range
    Dim licenseCol As Range
    Dim cell As Range
    
    Set WS = Worksheets("License Details")
    lc = WS.Range("A5").End(xlToRight).Column
    lr = WS.Range("A6").End(xlDown).Row
    
    For i = 6 To lc
        If WS.Cells(5, i).Value Like "*Issued*" Or WS.Cells(5, i).Value Like "*Expires*" Then
            If WS.Cells(5, i).Value Like "*Issued*" Then
                Set licenseCol = WS.Range(WS.Cells(6, i - 1), WS.Cells(lr, i - 1))
                ' 设置列宽
                WS.Cells(5, i - 1).ColumnWidth = 5
                ' 特殊处理SPL列
                If WS.Cells(5, i - 1).Value Like "*SPL*" Then
                    WS.Cells(5, i - 1).ColumnWidth = 6
                End If
                
                ' 通过单元格格式临时显示###，不修改原始值
                For Each cell In licenseCol
                    If cell.Value <> "" Then
                        ' 设置自定义格式：非空值显示###，空值显示空
                        cell.NumberFormat = """###"""
                        ' 可选：设置文本颜色
                        cell.Font.Color = RGB(128, 128, 128)
                    End If
                Next cell
            End If
            
            ' 收集日期列用于隐藏
            If dRng Is Nothing Then
                Set dRng = WS.Cells(1, i)
            Else
                Set dRng = Union(dRng, WS.Cells(1, i))
            End If
        End If
    Next i
    
    ' 隐藏日期列
    If Not dRng Is Nothing Then
        dRng.EntireColumn.Hidden = True
        Call ScrollToTop
    End If
End Sub

UnhideStates 子过程 #

Sub UnhideStates()
    Dim i As Long
    Dim WS As Worksheet
    Dim dRng As Range
    Dim licenseCol As Range
    Dim cell As Range
    
    Set WS = Worksheets("License Details")
    
    For i = 6 To 164
        If WS.Cells(5, i).Value Like "*Issued*" Or WS.Cells(5, i).Value Like "*Expires*" Then
            If WS.Cells(5, i).Value Like "*Issued*" Then
                lr = WS.Range("A6").End(xlDown).Row
                Set licenseCol = WS.Range(WS.Cells(6, i - 1), WS.Cells(lr, i - 1))
                ' 恢复列宽
                WS.Cells(5, i - 1).ColumnWidth = 13
                
                ' 恢复单元格格式，显示原始值
                For Each cell In licenseCol
                    If cell.Value <> "" Then
                        ' 恢复默认格式（可根据实际需求调整为文本或其他格式）
                        cell.NumberFormat = "General"
                        ' 恢复默认字体颜色
                        cell.Font.Color = RGB(0, 0, 0)
                    End If
                Next cell
            End If
            
            ' 收集日期列用于显示
            If dRng Is Nothing Then
                Set dRng = WS.Cells(1, i)
            Else
                Set dRng = Union(dRng, WS.Cells(1, i))
            End If
        End If
    Next i
    
    ' 显示日期列并设置列宽
    If Not dRng Is Nothing Then
        dRng.EntireColumn.Hidden = False
        dRng.EntireColumn.ColumnWidth = 13
        Call ScrollToTop
    End If
End Sub

关键修改说明 #

1. 避免永久性数据修改：使用cell.NumberFormat = """###"""设置自定义格式，仅改变显示内容，原始许可证编号仍保存在单元格中。
2. 正确遍历单元格：直接使用For Each cell In licenseCol引用当前单元格，替代ActiveCell和手动维护row变量的错误写法。
3. 限定工作表引用：所有Range和Cells操作前添加WS.前缀，避免因当前活动工作表变化导致错误。
4. 恢复格式与显示：在UnhideStates中恢复单元格的默认格式（General）和字体颜色，确保原始值正常显示。

内容的提问来源于stack exchange，提问作者Archie Weber