Excel VBA如何将超长结果数组拆分输出到多个工作表

安全阿岳

2026-8-28

问题背景

我在开发一款用于生成多组列表全排列、并自动剔除不符合规则排列的实用工具。由于涉及的列表和列表内取值数量极大，筛选前的原始排列数组规模可达数百万行。
此前生成排列使用的是Ejaz Ahmed开发的MixMatchColumns工具，该工具在小规模列表场景下运行稳定，但目前我的数据量已经达到其性能和容量上限。我了解到这类场景可以用关系数据库处理，但我没有相关搭建经验，判断该需求可以在Excel内通过数组拆分方案实现。
我是VBA新手，目前写的代码比较粗糙，但学习意愿充足，有足够耐心完成调试。目前能找到的参考资料大多讲解多工作表数据汇总到数组的方案，没有找到大数组拆分输出到多个工作表的实现方法。

具体需求

初始数组为ResultArray()，维度为lngNumberRows（总行数）、lngCol（总列数），数组第1行为表头行，示例场景下该数组包含200万行数据。
从Sheet2开始，每个工作表最多存放50万行数据，直到ResultArray内所有行全部输出完成。
后续需要通过一组If/Then规则精简数据，剔除不符合条件的行（例如：A列某行值为"Z"且同行C列值为"4"时，删除该行）。这部分VBA逻辑我已经基本完成，也了解自动筛选可以提升该步骤的处理效率；每行数据需要经过约65条规则校验，我有足够耐心完成这部分调试工作。
附加优化要求：筛选完成后，将所有有效行尽可能汇总到数量最少的工作表中。

注：MixMatchColumns原作者为Ejaz Ahmed，发布于2014年2月21日

现有VBA代码

Option Explicit '强制变量声明，规范编码习惯

'======================================================================
'MixMatchColumns 排列生成工具
'======================================================================
'功能：接收指定数据范围，将每列视为一个取值集合，生成所有集合元素的全排列
'参数说明：
'DataRange          - 存储各列取值列表的数据源范围
'ResultRange        - 排列结果的起始输出单元格
'DataHasHeaders     - 布尔值，标记数据源范围是否包含表头
'HeadersInResult    - 布尔值，标记结果输出时是否携带表头
'======================================================================
'原作者 :   Ejaz Ahmed
'发布日期 :   2014年2月21日
'联系邮箱 :   StrugglingToExcel@outlook.com
'======================================================================
Sub MixMatchColumns(ByRef DataRange As Range, _
                    ByRef ResultRange As Range, _
                    Optional ByVal DataHasHeaders As Boolean = False, _
                    Optional ByVal HeadersInResult As Boolean = False)

Dim rngData As Range
Dim rngResults As Range
Dim lngCount As Long
Dim lngCol As Long
Dim lngNumberRows As Long
Dim ItemCount() As Long
Dim RepeatCount() As Long
Dim PatternCount() As Long
'循环过程使用的长整型变量
Dim lngForRow As Long
Dim lngForPattern As Long
Dim lngForItem As Long
Dim lngForRept As Long
'存储源数据和结果的临时数组
Dim DataArray() As Variant
Dim ResultArray() As Variant

'如果数据源包含表头，调整数据范围跳过表头行
Set rngData = DataRange
If DataHasHeaders Then
    Set rngData = rngData.Offset(1).Resize(rngData.Rows.Count - 1)
End If

'读取源数据到数组，获取总列数
DataArray = rngData.Value
lngCol = rngData.Columns.Count

'初始化计数数组
ReDim ItemCount(1 To lngCol)
ReDim RepeatCount(1 To lngCol)
ReDim PatternCount(1 To lngCol)

'统计每列的有效取值数量
For lngCount = 1 To lngCol
    ItemCount(lngCount) = _
        Application.WorksheetFunction.CountA(rngData.Columns(lngCount))
    If ItemCount(lngCount) = 0 Then
        MsgBox "第" & lngCount & "列没有有效取值"
        Exit Sub
    End If
Next

'计算全排列总行数
lngNumberRows = Application.Product(ItemCount)

'初始化结果数组
ReDim ResultArray(1 To lngNumberRows, 1 To lngCol)

'计算每个取值的重复次数
RepeatCount(lngCol) = 1
For lngCount = (lngCol - 1) To 1 Step -1
    RepeatCount(lngCount) = ItemCount(lngCount + 1) * _
                                RepeatCount(lngCount + 1)
Next lngCount

'计算每个取值模式的循环次数
For lngCount = 1 To lngCol
    PatternCount(lngCount) = lngNumberRows / _
            (ItemCount(lngCount) * RepeatCount(lngCount))
Next

'遍历每列生成排列值
For lngCount = 1 To lngCol
lngForRow = 1
    '按模式循环
    For lngForPattern = 1 To PatternCount(lngCount)
        '遍历列内每个取值
        For lngForItem = 1 To ItemCount(lngCount)
            '按重复次数填充值
            For lngForRept = 1 To RepeatCount(lngCount)
                ResultArray(lngForRow, lngCount) = _
                        DataArray(lngForItem, lngCount)
                lngForRow = lngForRow + 1
            Next lngForRept
        Next lngForItem
    Next lngForPattern
Next lngCount

'输出结果
Set rngResults = ResultRange(1, 1).Resize(lngNumberRows, lngCol)
'如果需要输出表头
If DataHasHeaders And HeadersInResult Then
    rngResults.Rows(1).Value = DataRange.Rows(1).Value
    Set rngResults = rngResults.Offset(1)
End If
rngResults.Value = ResultArray()

'以下为自行编写的未完成测试代码
    'Dim lngTabs As Long
    'Dim lngRemainingRows As Long
    
    'lngTabs = lngNumberRows / (1000000 - 1)
    'Dim lngTabCounter As Long
    'If lngNumberRows > 500000 Then
        'lngTabs = Round((lngNumberRows / 500000), 0)
        'Range("O1") = lngNumberRows
        'Range("O2") = lngCol
        
        'Dim I As Integer
        'Dim SplitIdx As Integer
        
        'For I = 1 To lngNumberRows
            'If lngNumberRows > 10 Then
                'SplitIdx = I - 1
                'Exit For
            'End If
        'Next I
        
        'If SplitIdx = 0 Or SplitIdx = 10 Then
        
        'End If
        
        'Range("O3") = SplitIdx
        
        '测试拆分方案
              'Dim IC As Long
              'IC = lngNumberRows / 2
              'Range("O3") = IC
              'Dim ar2() As Variant
              'Dim ar3() As Variant
              
              'Dim I As Integer
            
              'ReDim ar2(IC - 1)
              'ReDim ar3(UBound(ResultArray) - IC)
            
              'For I = 0 To IC - 1
               'ar2(I) = ResultArray(I)
              'Next
            
              'For I = 0 To UBound(ResultArray) - IC
               'ar3(I) = ResultArray(I + IC - 1)
              'Next
            
            '测试输出
              'Debug.Print "ar2:"
              'For I = LBound(ar2) To UBound(ar2)
               'Debug.Print ar2(I)
              'Next
            
              'Debug.Print "======" & Chr(13) & "ar3:"
            
              'For I = LBound(ar3) To UBound(ar3)
               'Debug.Print ar3(I)
              'Next
        
        'rngResults.Value = ResultArray()
        'For I = LBound(ar2) To UBound(ar2)
            'Range("N12").Value = ar2(I)
            'Next
            
        'For I = LBound(ar3) To UBound(ar3)
            'Range("S12").Value = ar3(I)
            'Next
End Sub


Sub CoverMacro()
'交互入口宏
Dim rngData As Range
Dim rngResults As Range
Dim booDataHeader As Boolean
Dim booResultHeader As Boolean
Dim lngAns As Long
Dim strMessage As String
Dim strTitle As String

strTitle = "全排列生成工具"

strMessage = "请选择存储取值列表的数据源范围：" _
    & vbNewLine & "确保范围内无空单元格"

On Error Resume Next
Set rngData = Application.InputBox(strMessage, strTitle, , , , , , 8)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If
    

strMessage = "数据源是否包含表头？"
lngAns = MsgBox(strMessage, vbYesNo, strTitle)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

If lngAns = vbYes Then
    booDataHeader = True
Else
    booDataHeader = False
End If

strMessage = "请选择结果输出的起始单元格"
Set rngResults = Application.InputBox(strMessage, strTitle, , , , , , 8)
If Not Err.Number = 0 Then
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

If booDataHeader Then
    strMessage = "结果中是否需要保留表头？"
    lngAns = MsgBox(strMessage, vbYesNo, strTitle)
    
    If Not Err.Number = 0 Then
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If

    If lngAns = vbYes Then
        booResultHeader = True
    Else
        booResultHeader = False
    End If
Else
    booResultHeader = False
End If

Call MixMatchColumns(rngData, rngResults, booDataHeader, booResultHeader)
End Sub

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