如何使用VBA复制工作表指定区域转格式适配Power BI数据源

我有一个资源工作表，需要将其转换为适配Power BI数据源的格式，涉及从源工作表复制特定区域到目标工作表并调整目标地址，以下是数据现有格式与目标格式的示意图：

我自行编写了VBA脚本实现该功能，但运行效果不佳，实际业务中的数据表有250+行、600-800列，请问有什么解决思路或优化建议吗？相关代码如下：

Sub PopulateCells()
    Dim rng As Range
    Dim rng2 As Range
    Dim LastCell As String
    Dim Dest As String

    Application.ScreenUpdating = False
    
    ' 清空BI工作表
    Ark4.Cells.Delete
    
    ' 初始化行列参数
    Startrow = 4
    StartColumn = 7
    EndColumn = 18
    
    Ark3.Activate
    
    ' 获取数据范围参数
    Set rng = Sheets(Sheets.Count).Cells
    lastrow = Last(1, rng)
    dColumns = Last(2, rng)
    aKol = dColumns
    LastCell = Last(3, rng)
    Set rng = Parent.Range("G4", LastCell)
    Set rng2 = Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
    cColumn = Round(dColumns / 12, 0) ' 总列数除以12（12个月为1年
    
    ' 定位最后一个有数据的列地址
    sKol = Ark3.Cells(3, Columns.Count).End(xlToLeft).Address
        
    ' 初始化目标表占位数据适配代码逻辑
    Ark4R = 3
    Ark4.Range("A1:" & sKol).Value = "x"
        
    ' 遍历数据源所有行
    For I = 4 To lastrow
        
        ' 按12列为一组遍历所有列
        For ii = 1 To cColumn
            
            ' 定义当前12列的待检测范围
            Set rng2 = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
            
                ' 仅当该范围有数据时执行复制逻辑
                If WorksheetFunction.countA(rng2) <> 0 Then
                    ' 回填年份和月份到源表E、F列
                    Ark3.Range("E" & I).Value = rng2.EntireColumn.Cells(1).Value
                    Ark3.Range("F" & I).Value = rng2.EntireColumn.Cells(1).Offset(1).Value
                    aRowSource = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn)).Row
                
                    ' 复制到目标表
                    rng2.EntireRow.Copy ' 复制整行
                    Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll    ' 粘贴到目标表下一个空行
                    Application.CutCopyMode = False
                    Ark4.Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).ClearContents   ' 清空目标行多余的工时数据
                    aRowDest = Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).Row   ' 记录目标行号
                    Dest = rng2.Address(RowAbsolute:=False, ColumnAbsolute:=False)  ' 获取源数据范围地址
                    Dest = Replace(Dest, aRowSource, aRowDest)  ' 替换为目标行对应的地址
                    rng2.Copy Ark4.Range(Dest)  ' 复制对应12个月的数据到目标位置
                    Application.CutCopyMode = False

                End If

                ' 滑动12列到下一年
                StartColumn = StartColumn + 12
                EndColumn = EndColumn + 12
        
        Next ii
        
        ' 新增预留行用于其他流程插入运营工时
        Ark3.Range(Cells(Startrow, 1), Cells(Startrow, 4)).Copy
        Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        
        ' 计数器更新
        Startrow = Startrow + 1
        StartColumn = 7
        EndColumn = 18
    Next I

End Sub

核心性能问题根源 #

原代码性能瓶颈主要来自高频单元格读写、剪贴板操作、频繁的对象调用，还有冗余的激活/选择类操作，这类操作在大批量数据下耗时会指数级上升。

具体优化方案 #

• 关闭多余的Excel响应项
  除了已经关闭的屏幕更新，还要额外关闭事件触发、自动重算，执行完再恢复，避免Excel后台自动操作拖慢速度：

' 代码执行前关闭
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' 代码结束前恢复
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

• 替换剪贴板操作为数组读写
  不要用Copy/Paste这种依赖剪贴板的操作，直接通过数组批量读取源表所有数据，在内存里处理完一次性写入目标表，比逐行逐范围复制快几十倍，250行800列的数据完全可以一次性读到数组里处理。
• 去掉不必要的对象操作

1. 不要用Activate、ActiveCell这类依赖激活状态的属性，直接显式指定工作表，避免页面切换的性能损耗。
2. 预先记录目标表的写入行号，不要每次循环都用End(xlUp)找最后一行，直接用一个变量记录当前写入行号，每次写完+1即可。

• 合并冗余读写步骤
  原代码反复读写E、F列，然后复制整行再清空部分内容再粘贴，这几步完全可以合并：直接读取源行前6列的内容赋值到目标行对应位置，再把12列的时间段数据赋值过去，不用先复制整行再清空。
• 调整空值判断逻辑
  WorksheetFunction.CountA对小范围没问题，但你可以提前把要判断的12列数据读到数组里判断非空值，比调用工作表函数更快。

可选替代方案 #

如果VBA优化后还是达不到预期，可以直接用Power Query做数据转换，不用写代码，直接在Power Query里逆透视月份列，一步就能把宽表转成Power BI适配的长表格式，处理上千行列转换速度比VBA更快，还支持自动刷新。

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