Excel VBA批量计算单元格字符串宽度时程序卡顿求助

问题根源 #

你的代码在处理大量单元格时崩溃，核心原因是每次调用GetLabelSize都重复创建/销毁GDI资源（设备上下文DC、位图、字体对象），一万次循环会产生极高的资源开销，即便手动清理也可能因API调用的微小延迟或资源释放不彻底导致内存泄漏，最终触发Excel崩溃。此外，循环中频繁创建Range对象也会增加VBA与Excel交互的额外开销。

优化方案 #

1. 复用GDI资源：将设备上下文(DC)、基础位图等资源初始化移到循环外，仅创建一次，循环结束后统一销毁，避免重复创建的开销。
2. 缓存字体对象：相同字体参数（名称、大小、加粗）的情况下复用字体对象，无需每次重新创建。
3. 减少Excel对象交互：批量读取单元格值，避免在循环中频繁创建Range对象；关闭Excel的自动计算、事件触发等后台功能。
4. 优化资源清理逻辑：确保GDI资源的释放顺序正确，彻底避免资源泄漏。

修改后的完整代码 #

'API Declares
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, _
                                                                             ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, _
                                                                            ByVal lpsz As String, ByVal cbString As Long, lpSize As FNTSIZE) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long

Private Const LOGPIXELSY As Long = 90

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type FNTSIZE
    cx As Long
    cy As Long
End Type

'全局变量用于复用GDI资源
Private tempDC As LongPtr
Private tempBMP As LongPtr
Private oldBMP As LongPtr
Private logPixelsY As Long

Sub textsize()
    Dim frow As Long, lrow As Long, irow As Long
    Dim cellValues As Variant '批量存储单元格值
    Dim fontName As String
    Dim fontSize As Single
    Dim isBold As Boolean
    Dim sText As String
    Dim stringWidth As Single
    Dim currentFont As LongPtr
    Dim oldFont As LongPtr
    Dim lf As LOGFONT
    
    '关闭Excel后台功能，减少干扰
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    frow = 4
    lrow = 11701
    fontName = "Verdana"
    fontSize = 11
    
    '批量读取需要的单元格值，减少Excel交互
    cellValues = Range("A" & frow & ":B" & lrow).Value2
    
    '初始化GDI资源，仅执行一次
    InitializeGDIResources
    
    '初始化字体参数
    logPixelsY = GetDeviceCaps(GetDC(0), LOGPIXELSY)
    ReleaseDC 0, GetDC(0)
    
    lf.lfFaceName = fontName & Chr$(0)
    lf.lfHeight = -MulDiv(fontSize, logPixelsY, 72)
    lf.lfItalic = False
    lf.lfStrikeOut = False
    lf.lfUnderline = False
    
    For irow = 1 To UBound(cellValues, 1)
        sText = cellValues(irow, 2)
        If sText <> "" Then
            '判断是否需要加粗
            isBold = (Len(cellValues(irow, 1)) = 4)
            
            '更新字体加粗属性，仅当状态变化时重新创建字体
            If isBold Then
                lf.lfWeight = 800
            Else
                lf.lfWeight = 400
            End If
            
            '创建字体并选择到DC
            currentFont = CreateFontIndirect(lf)
            oldFont = SelectObject(tempDC, currentFont)
            
            '计算文本宽度
            stringWidth = GetStringPixelWidthFromDC(sText, tempDC)
            
            '恢复原字体并销毁当前字体
            SelectObject(tempDC, oldFont)
            DeleteObject currentFont
            
            '批量设置字体格式
            With Range("A" & frow + irow - 1 & ":D" & frow + irow - 1).Font
                .Name = fontName
                .Size = fontSize
                .Bold = isBold
            End With
            
            Debug.Print frow + irow - 1, stringWidth
        End If
    Next irow
    
    '清理GDI资源
    CleanupGDIResources
    
    '恢复Excel设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub

'初始化GDI资源
Private Sub InitializeGDIResources()
    tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
    tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
    oldBMP = SelectObject(tempDC, tempBMP)
End Sub

'清理GDI资源
Private Sub CleanupGDIResources()
    SelectObject(tempDC, oldBMP)
    DeleteObject tempBMP
    DeleteDC tempDC
End Sub

'直接使用已初始化的DC计算文本宽度
Private Function GetStringPixelWidthFromDC(text As String, hdc As LongPtr) As Single
    Dim textsize As FNTSIZE
    GetTextExtentPoint32 hdc, text, Len(text), textsize
    GetStringPixelWidthFromDC = textsize.cx
End Function

关键优化说明 #

• GDI资源复用：InitializeGDIResources和CleanupGDIResources分别在循环前后执行一次，避免一万次重复创建DC和位图。
• 批量读取单元格：用cellValues = Range(...).Value2一次性读取所有需要的单元格值，将VBA与Excel的交互从一万次减少到一次。
• 字体按需创建：仅当加粗状态变化时重新创建字体，减少不必要的CreateFontIndirect调用。
• 关闭Excel后台功能：禁用自动计算、事件触发等，避免Excel在后台消耗资源。

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