Excel VBA宏优化：判断单元格非无填充色并批量填充空白

问题背景 #

我是自学Excel VBA的新手，需要编写宏在导入新数据后填充打卡表中的颜色空白。工作日对应固定填充色：

• 周一=44
• 周二=3
• 周三=26
• 周四=28
• 周五=27
  导入数据时会因整批完成产生空白区域。最初的代码只能针对单一颜色执行填充，若为5种颜色编写重复代码过于繁琐，希望通过Interior.ColorIndex <> xlNone的判断逻辑简化代码。后续自行编写了多列批量处理的宏，但不确定是否应自行回答问题或寻找原帮助者的答案，寻求指导。

初始代码 #

For Each CELL In ActiveSheet.Range("BG9:BG500")
If Range("BG" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex = 26 Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

自行优化后的代码 #

Sub FILLGAPS()

For Each CELL In ActiveSheet.Range("BP9:BP500")
If Range("BP" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BO9:BO500")
If Range("BO" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BN9:BN500")
If Range("BN" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BM9:BM500")
If Range("BM" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BL9:BL500")
If Range("BL" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BK9:BK500")
If Range("BK" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BJ9:BJ500")
If Range("BJ" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BI9:BI500")
If Range("BI" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BH9:BH500")
If Range("BH" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

For Each CELL In ActiveSheet.Range("BG9:BG500")
If Range("BG" & CELL.Row).Interior.ColorIndex = xlNone And Range("BG" & CELL.Row + 1).Interior.ColorIndex <> xlNone Then ActiveSheet.Range("BG" & CELL.Row + 1).Copy CELL
Next CELL

End Sub

进一步优化方案 #

你当前的优化代码存在大量重复逻辑，仅列范围不同，可以通过遍历列集合来大幅简化代码，同时优化复制操作的精准度：

Sub FILLGAPS()
    Dim targetColumns As Range
    Dim singleCol As Range
    Dim cell As Range
    
    ' 定义需要处理的列范围：BG到BP列，行9至500
    Set targetColumns = ActiveSheet.Range("BG9:BP500").Columns
    
    ' 遍历每一列
    For Each singleCol In targetColumns
        ' 遍历列中的每个单元格
        For Each cell In singleCol.Cells
            ' 判断条件：当前单元格无填充，且下一行BG列有填充颜色
            If cell.Interior.ColorIndex = xlNone And _
               ActiveSheet.Cells(cell.Row + 1, "BG").Interior.ColorIndex <> xlNone Then
                ' 仅复制格式到当前单元格，避免复制不必要内容
                ActiveSheet.Cells(cell.Row + 1, "BG").Copy
                cell.PasteSpecial Paste:=xlPasteFormats
            End If
        Next cell
    Next singleCol
    
    ' 清除剪贴板状态，避免干扰后续操作
    Application.CutCopyMode = False
End Sub

这个版本的优势：

• 只需一次列范围定义，后续调整列数或列范围时修改一行代码即可
• 使用xlPasteFormats仅复制填充格式，比直接复制单元格更高效精准
• 代码结构清晰，减少重复冗余，便于维护

社区提问处理建议 #

1. 如果你已经解决了问题，完全可以自行回答——Stack Exchange社区非常鼓励用户分享自己的解决方案，这能帮到其他遇到相同问题的开发者。
2. 回答时可以清晰梳理：问题背景、初始代码的局限、你的优化思路、最终代码，这样的回答完整且有参考价值。
3. 如果之前有帮助者给过思路，你可以在回答中提及参考了对方的思路后完成了优化，这是尊重他人贡献的做法。

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