Excel VBA批量复制单元格Interior.Color遇全部变黑问题

问题分析 #

你当前代码的核心问题：

• 直接对整个区域的Interior.Color赋值时，VBA会仅提取右侧表达式第一个单元格的颜色值，再批量应用到整个目标区域。如果原区域首个单元格的DisplayFormat.Interior.Color为黑色，就会导致所有单元格统一变黑。
• DisplayFormat是只读属性，用于获取单元格的显示格式，直接赋值给Interior.Color的逻辑本身不成立，无法实现逐单元格的对应颜色复制。

高效单行实现方案（无需循环） #

使用Copy+PasteSpecial方法是Excel VBA中批量复制格式最高效的方式之一，可直接实现逐单元格对应复制背景色：

' 替换原代码中步骤2及p_Texture赋值的相关行
p_OriginalTexture.Copy
p_Texture.PasteSpecial Paste:=xlPasteInterior, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False ' 清除剪贴板状态，避免后续操作干扰

修正后的完整代码 #

Public Sub Initialize(ByVal WorkbookName As String, ByVal SheetName As String, ByVal n_SheetRow As Long, ByVal n_SheetColumn As Long, ByVal n_LastRow As Long, ByVal n_LastColumn As Long)
    Dim TextureSheet As Range
    p_SheetRow = n_SheetRow
    p_SheetColumn = n_SheetColumn
    p_LastRow = n_LastRow
    p_LastColumn = n_LastColumn
    Set TextureSheet = Workbooks(WorkbookName).Sheets(SheetName).Range("A1")
    ' 限定父工作表，避免ActiveSheet影响
    Set p_OriginalTexture = TextureSheet.Parent.Range(TextureSheet.Offset(p_SheetRow, p_SheetColumn), TextureSheet.Offset(p_SheetRow + p_LastRow, p_SheetColumn + p_LastColumn))
    ' 复制背景色到目标区域
    p_OriginalTexture.Copy
    Set p_Texture = p_OriginalTexture.Offset(p_LastRow + 1, 0)
    p_Texture.PasteSpecial Paste:=xlPasteInterior
    Application.CutCopyMode = False
    p_Initialized = True
End Sub

补充说明 #

• 原代码中Range(...)未指定父工作表，易受当前活动工作表影响，修正后用TextureSheet.Parent.Range确保引用目标工作表的区域。
• 若需要复制全部单元格格式（而非仅背景色），可将xlPasteInterior替换为xlPasteFormats。

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