打破一个大的Excel程序

我有两个程序，由于我在Excel中的数据超出了一个非常大的数量，两个内存都用完了。

Sub format() Dim x, Y(), i&, j&, k&, s x = Range("A1", Cells(1, Columns.count).End(xlToLeft)).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x, 2) .Item(x(1, i)) = i Next i x = Application.Trim(Range("BL3", Cells(Rows.count, "BL").End(xlUp)).Value) ReDim Y(1 To UBound(x), 1 To .count): j = 1 For i = 1 To UBound(x) If InStr(x(i, 1), "==") = 0 Then s = Split(x(i, 1)) If .Exists(s(0)) Then k = .Item(s(0)): Y(j, k) = mid(x(i, 1), Len(s(0)) + 2) End If Else j = j + 1 End If Next i End With [a2].Resize(j, UBound(Y, 2)).Value = Y() End Sub 

以上是我用来将一列数据拆分/修剪成几行/列的程序。

我把数据分成两列，每列包含60k行，我需要做的就是一次读取BL，读取BO，并继续从第一行开始，将第二行数据放在新行下面完

Answer 1

像这样（未testing）可能会为你工作。 它避免了使用较小尺寸的块创build一个巨大的二维数组。

 Sub format() Const BLOCK_SIZE As Long = 10000 Dim x, Y(), i&, j&, k&, s Dim d As Object Dim rOffset As Long Dim xCount As Long Set d = CreateObject("Scripting.Dictionary") d.CompareMode = 1 x = Range("A1", Cells(1, Columns.Count).End(xlToLeft)).Value For i = 1 To UBound(x, 2) 'using Add: you probably want this to error if duplicates exist... d.Add x(1, i), i Next i x = Application.Trim(Range("BL3", Cells(Rows.Count, "BL").End(xlUp)).Value) xCount = UBound(x) rOffset = 0 ReDim Y(1 To BLOCK_SIZE, 1 To d.Count) j = 1 For i = 1 To xCount If InStr(x(i, 1), "==") = 0 Then s = Split(x(i, 1)) If d.Exists(s(0)) Then k = d(s(0)) Y(j, k) = Mid(x(i, 1), Len(s(0)) + 2) End If Else j = j + 1 If j > BLOCK_SIZE Then [a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y() ReDim Y(1 To BLOCK_SIZE, 1 To d.Count) j = 1 rOffset = rOffset + BLOCK_SIZE End If End If Next i [a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y() End Sub