32位Excel大表格VBA代码崩溃，求助优化及拆分方案

我有一个37行、8000列的Excel表格，结构比较特殊：观测值存储在列中而非行内，呈现「类别（如Title）-条目-类别（如Author）-条目」的交替排列形式。我的目标是将其整理为规范数据集：首行为类别，其余行为观测值。

遇到的核心问题是：部分观测值缺少部分类别（例如第1-5列没有"Funding"类别，该类别名在第12行、对应内容在第13行）。我在@Xabier的帮助下编写了首段VBA代码，小数据集测试有效，但处理完整大数据集时Excel直接崩溃。

环境限制：我使用Windows10 64位系统，但因学校要求只能使用32位Excel，学校不愿重装为64位版本。我尝试用数组改写代码但未成功，因本人VBA经验不足，求助如何简化、拆分代码以解决崩溃问题。

Sub foo()
 Dim ws As Worksheet: Set ws = Sheets("Sheet2")
 'declare and set your Sheet above
 'lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find the last row with data on Column A
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(2, i).Value = "Title" Then 'if category is not found,
 ws.Cells(2, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(2, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(4, i).Value = "Author" Then 'if category is not found,
 ws.Cells(4, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(4, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(6, i).Value = "Unit" Then 'if category is not found,
 ws.Cells(6, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(6, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(8, i).Value = "Keyword" Then 'if category is not found,
 ws.Cells(8, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(8, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(10, i).Value = "Abstract" Then 'if category is not found,
 ws.Cells(10, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(10, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(12, i).Value = "Funding" Then 'if category is not found,
 ws.Cells(12, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(12, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(14, i).Value = "Source" Then 'if category is not found,
 ws.Cells(14, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(14, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(16, i).Value = "Date" Then 'if category is not found,
 ws.Cells(16, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(16, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(18, i).Value = "Page" Then 'if category is not found,
 ws.Cells(18, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(18, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(20, i).Value = "ISSN" Then 'if category is not found,
 ws.Cells(20, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(20, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(22, i).Value = "CN" Then 'if category is not found,
 ws.Cells(22, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(22, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(24, i).Value = "Language" Then 'if category is not found,
 ws.Cells(24, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(24, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(26, i).Value = "ClassificationNumber" Then 'if category is not found,
 ws.Cells(26, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(26, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(28, i).Value = "DOI" Then 'if category is not found,
 ws.Cells(28, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(28, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(30, i).Value = "TimesCited" Then 'if category is not found,
 ws.Cells(30, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(30, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(32, i).Value = "Citesothers" Then 'if category is not found,
 ws.Cells(32, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(32, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(34, i).Value = "CitedReferences" Then 'if category is not found,
 ws.Cells(34, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(34, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
 For i = 1 To 8000 'loop from column 1 to last
 If Not ws.Cells(36, i).Value = "Citedby" Then 'if category is not found,
 ws.Cells(36, i).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(36, i).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Next i
End Sub

第一次数组尝试 #

Sub dd()
 Dim firstRow As Long
 Dim lastRow As Long
 firstRow = 1
 lastRow = 37
 Dim tableArray() As Variant
 Dim k As Long
 With dataWorkbook.Worksheets("Sheet2")
 tableArray = .Range(.Cells(firstRow, 1), _
 .Cells(lastRow, 8000)).Value
 For k = 1 To 8000 'for each column in the table
 If tableArray(4, k) = "Author" Then
 Else
 ws.Cells(4, k).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(4, k).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 If tableArray(6, k) = "Keyword" Then
 Else
 ws.Cells(6, k).Insert Shift:=xlDown 'insert a blank cell in column i
 ws.Cells(6, k).Insert Shift:=xlDown 'again insert a second blank cell in column i
 End If
 Dim worksheetRange As Range
 Set worksheetRange = .Range(.Cells(firstRow, 1), _
 .Cells(lastRow, 8000))
 worksheetRange.Value = tableArray
 End With
End Sub

数组加载尝试 #

Sub dynamicMultidimensionalArray()
 Dim Chinese() As Variant
 Dim Dimension1 As Long, dimension2 As Long
 Dimension1 = Range("A1").End(xlDown).Row + 1
 dimension2 = Range("A1").End(xlToRight).Column
 ReDim Chinese(0 To Dimension1, 0 To dimension2)
 For Dimension1 = LBound(Chinese, 1) To UBound(Chinese, 1)
 For dimension2 = LBound(Chinese, 2) To UBound(Chinese, 2)
 Chinese(Dimension1, dimension2) = Range("A1").Offset(Dimension1, dimension2).Value
 Next dimension2
 Next Dimension1
End Sub

为什么原代码会崩溃？ #

原代码的问题在于频繁操作工作表单元格：你循环了17次8000列，每次判断不对就插入两个单元格，这意味着Excel要执行17×8000×2次的单元格移位操作，每次操作都会触发界面刷新和后台计算。32位Excel的内存上限本来就低，这种持续的高IO操作直接耗尽了内存，导致崩溃。

你的数组尝试没成功，是因为你还是在操作工作表单元格，没真正利用数组在内存中处理数据的优势。

优化后的内存数组处理代码 #

这个版本把所有数据读到内存数组里完成修改，最后一次性写回工作表，彻底避免了频繁的IO操作：

Sub RestructureData()
    Dim ws As Worksheet
    Dim sourceData As Variant
    Dim processedData As Variant
    Dim totalRows As Long
    Dim categories As Variant
    Dim catRow As Long
    Dim col As Long
    Dim row As Long
    Dim i As Long
    
    ' 设置目标工作表
    Set ws = ThisWorkbook.Sheets("Sheet2")
    
    ' 关闭屏幕更新和自动计算，大幅提升速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 定义数据范围（37行，8000列）
    totalRows = 37
    ' 一次性读取所有源数据到内存数组
    sourceData = ws.Range(ws.Cells(1, 1), ws.Cells(totalRows, 8000)).Value
    
    ' 定义所有需要的类别及其对应的行索引（数组是1-based）
    categories = Array( _
        Array("Title", 2), Array("Author", 4), Array("Unit", 6), Array("Keyword", 8), _
        Array("Abstract", 10), Array("Funding", 12), Array("Source", 14), Array("Date", 16), _
        Array("Page", 18), Array("ISSN", 20), Array("CN", 22), Array("Language", 24), _
        Array("ClassificationNumber", 26), Array("DOI", 28), Array("TimesCited", 30), _
        Array("Citesothers", 32), Array("CitedReferences", 34), Array("Citedby", 36) _
    )
    
    ' 初始化处理后的数组，复制源数据
    ReDim processedData(1 To totalRows, 1 To 8000)
    For row = 1 To totalRows
        For col = 1 To 8000
            processedData(row, col) = sourceData(row, col)
        Next col
    Next row
    
    ' 遍历每一列处理缺失的类别
    For col = 1 To 8000
        ' 检查每个类别是否存在
        For i = LBound(categories) To UBound(categories)
            catRow = categories(i)(1)
            ' 如果当前列的对应行不是目标类别，模拟插入两个空单元格的效果
            If processedData(catRow, col) <> categories(i)(0) Then
                ' 从后往前移位，避免覆盖未处理的数据
                For row = totalRows To catRow Step -1
                    processedData(row, col) = processedData(row - 2, col)
                Next row
                ' 补上空值
                processedData(catRow, col) = ""
                processedData(catRow + 1, col) = ""
            End If
        Next i
    Next col
    
    ' 一次性将处理好的数据写回工作表
    ws.Range(ws.Cells(1, 1), ws.Cells(totalRows, 8000)).Value = processedData
    
    ' 恢复Excel的正常设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据处理完成！"
End Sub

极端内存情况：分批次处理 #

如果32位Excel还是内存吃紧，可以试试分批次处理列，每次处理一部分，释放内存后再处理下一批：

Sub RestructureDataBatch()
    Dim ws As Worksheet
    Dim sourceData As Variant
    Dim processedData As Variant
    Dim totalRows As Long
    Dim categories As Variant
    Dim catRow As Long
    Dim colStart As Long
    Dim colEnd As Long
    Dim batchSize As Long
    Dim col As Long
    Dim row As Long
    Dim i As Long
    
    Set ws = ThisWorkbook.Sheets("Sheet2")
    totalRows = 37
    batchSize = 1000 ' 每次处理1000列，可根据内存情况调整
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    categories = Array( _
        Array("Title", 2), Array("Author", 4), Array("Unit", 6), Array("Keyword", 8), _
        Array("Abstract", 10), Array("Funding", 12), Array("Source", 14), Array("Date", 16), _
        Array("Page", 18), Array("ISSN", 20), Array("CN", 22), Array("Language", 24), _
        Array("ClassificationNumber", 26), Array("DOI", 28), Array("TimesCited", 30), _
        Array("Citesothers", 32), Array("CitedReferences", 34), Array("Citedby", 36) _
    )
    
    ' 分批次循环处理列
    For colStart = 1 To 8000 Step batchSize
        colEnd = colStart + batchSize - 1
        If colEnd > 8000 Then colEnd = 8000
        
        ' 读取当前批次的数据到内存
        sourceData = ws.Range(ws.Cells(1, colStart), ws.Cells(totalRows, colEnd)).Value
        ReDim processedData(1 To totalRows, 1 To colEnd - colStart + 1)
        
        ' 复制源数据到处理数组
        For row = 1 To totalRows
            For col = 1 To UBound(processedData, 2)
                processedData(row, col) = sourceData(row, col)
            Next col
        Next row
        
        ' 处理当前批次的列
        For col = 1 To UBound(processedData, 2)
            For i = LBound(categories) To UBound(categories)
                catRow = categories(i)(1)
                If processedData(catRow, col) <> categories(i)(0) Then
                    For row = totalRows To catRow Step -1
                        processedData(row, col