VBA大数据批量填充列效率优化求助：5万行循环耗时过长

原代码的核心问题 #

• Select/ActiveCell拖慢速度：每次Select和操作ActiveCell都会触发Excel界面刷新，5万行数据下这个开销会被放大到极致，是耗时的主要原因之一。
• 筛选未生效：原代码的Do Until ActiveCell.Value = ""会逐行遍历，包括筛选后隐藏的行，完全没利用到筛选的作用。
• Macro6逻辑错误：当单元格值为"UK"时，先赋值UKI紧接着又赋值EMEA，导致UK的结果被覆盖，属于明显bug。

优化方案1：利用可见区域+避免Select操作 #

先关闭Excel后台耗时操作，直接操作筛选后的可见单元格，跳过界面交互开销：

Sub Macro6_Optimized()
    Dim ws As Worksheet
    Dim targetRange As Range
    Dim cell As Range
    
    ' 关闭耗时后台操作
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveSheet
    ' 插入新列
    ws.Range("AL2").EntireColumn.Insert
    
    ' 筛选目标值
    ws.Range("A1").CurrentRegion.AutoFilter Field:=42, Criteria1:=Array("Germany", "UK", "EMEA"), Operator:=xlFilterValues
    
    ' 获取AQ列第3行开始的可见单元格区域
    On Error Resume Next ' 防止筛选后无可见行报错
    Set targetRange = ws.Range("AQ3:AQ" & ws.Cells(ws.Rows.Count, "AQ").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not targetRange Is Nothing Then
        For Each cell In targetRange
            Select Case cell.Value
                Case "Germany"
                    cell.Offset(0, -5).Value = "Germany"
                Case "UK"
                    cell.Offset(0, -5).Value = "UKI"
                Case "EMEA"
                    cell.Offset(0, -5).Value = "EMEA"
            End Select
        Next cell
    End If
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub Macro7_Optimized()
    Dim ws As Worksheet
    Dim targetRange As Range
    Dim cell As Range
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveSheet
    ' 清除现有筛选
    If ws.FilterMode Then ws.ShowAllData
    
    ' 筛选目标值
    ws.Range("A1").CurrentRegion.AutoFilter Field:=38, Criteria1:=Array("Americas", "Asia/Pacific", "EMEA"), Operator:=xlFilterValues
    
    ' 获取AM列第3行开始的可见单元格区域
    On Error Resume Next
    Set targetRange = ws.Range("AM3:AM" & ws.Cells(ws.Rows.Count, "AM").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not targetRange Is Nothing Then
        For Each cell In targetRange
            Select Case cell.Value
                Case "Americas"
                    cell.Offset(0, -1).Value = "Americas"
                Case "EMEA"
                    cell.Offset(0, -1).Value = "EMEA"
                Case "Asia/Pacific"
                    cell.Offset(0, -1).Value = "APAC"
            End Select
        Next cell
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

优化方案2：数组批量处理（最快，适配大数据量） #

对于5万行数据，最快的方式是把整列数据读到内存数组中，在内存完成所有判断赋值后，再一次性写回工作表，彻底避免逐单元格操作：

Sub Macro6_ArrayOptimized()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sourceArr As Variant
    Dim targetArr As Variant
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveSheet
    ws.Range("AL2").EntireColumn.Insert
    
    lastRow = ws.Cells(ws.Rows.Count, "AQ").End(xlUp).Row
    ' 把源列（AQ）和目标列（AL）数据读到数组
    sourceArr = ws.Range("AQ3:AQ" & lastRow).Value
    targetArr = ws.Range("AL3:AL" & lastRow).Value
    
    ' 内存中循环处理
    For i = 1 To UBound(sourceArr)
        Select Case sourceArr(i, 1)
            Case "Germany"
                targetArr(i, 1) = "Germany"
            Case "UK"
                targetArr(i, 1) = "UKI"
            Case "EMEA"
                targetArr(i, 1) = "EMEA"
        End Select
    Next i
    
    ' 处理后的数据写回工作表
    ws.Range("AL3:AL" & lastRow).Value = targetArr
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub Macro7_ArrayOptimized()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sourceArr As Variant
    Dim targetArr As Variant
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set ws = ActiveSheet
    If ws.FilterMode Then ws.ShowAllData
    
    lastRow = ws.Cells(ws.Rows.Count, "AM").End(xlUp).Row
    sourceArr = ws.Range("AM3:AM" & lastRow).Value
    targetArr = ws.Range("AL3:AL" & lastRow).Value ' AM偏移-1对应AL列
    
    For i = 1 To UBound(sourceArr)
        Select Case sourceArr(i, 1)
            Case "Americas"
                targetArr(i, 1) = "Americas"
            Case "EMEA"
                targetArr(i, 1) = "EMEA"
            Case "Asia/Pacific"
                targetArr(i, 1) = "APAC"
        End Select
    Next i
    
    ws.Range("AL3:AL" & lastRow).Value = targetArr
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

关键优化点说明 #

1. 关闭后台操作：ScreenUpdating关闭界面刷新、EnableEvents禁止工作表事件、Calculation设为手动计算，三者共同大幅降低耗时。
2. 抛弃Select/ActiveCell：直接用Range对象和变量操作，跳过界面交互的冗余开销。
3. 数组批量处理：内存数组的操作速度是单元格操作的数百倍，5万行数据基本几秒即可完成。
4. 修复逻辑错误：用Select Case替代嵌套If，避免原Macro6中UK赋值被覆盖的问题，逻辑更清晰。

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