VBA缓慢写入数组以优化工作簿

只是想知道是否有人可以提供任何build议，可以提高我的代码写入数组的工作簿的速度。

我在一本工作手册中写了大约190万行数据到一张表，一次一页。 代码完成后，大约需要18个小时才能写入Excel工作簿，这似乎过分了。 这是设置。 我打开这样的工作簿： 

Dim ExcelAp As Excel.Application Dim ouputWorkbook As Excel.Workbook Set ExcelAp = New Excel.Application Set outputWorkbook = ExcelAp.Workbooks.Open("S:\Some Directory\Template.xlsx")

然后，我将数组中的工作簿的行加载到集合中，然后循环遍历工作簿中的范围以复制数组： 

 For lonSheetOneCounter = 2 to 999999 outputWorkbook.Worksheets(1).Range(_ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 1).Address & ":" & _ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 21).Address).Value = _ outputCollection.item(lonSheetOneCounter - 1) Next lonSheetOneCounter

其他纸张的复印方法相同。 我已经将excel的工作簿和实例隐藏起来了，我已经将工作簿的计算转换为手动，并且也closures了屏幕更新，但是完成复制到新的工作簿还需要大约18个小时的时间。

我已经尝试为entier工作表制作一个2维数组，但是无论我使用哪种方法，当我尝试将该数组复制到工作簿时，我都会遇到“内存不足错误”。

我不确定是否还有什么可以做的，以减less错误，减less复制的时间，但如果有人有一个build议，我全部耳朵。 值得一提的是，这个macros被安置在另一个excel工作簿中，这个excel工作簿是从我试图复制的工作簿中分离出来的一个excel实例中运行的。

编辑：这里略有添加。 我注意到，我想引起注意的事情也使我认为有可能加快这一进程。 我注意到这个macros逐渐减慢。 第一个X的行数写得非常快，随着每一行的写入，下面的行似乎越来越慢…

我将尝试一个实验，在其中设置我的模板，以便自动加载包含一百万条使用行的电子表格……sorting依据底部的build议提示。 我想知道如果excel是不得不为所有额外的行分配内存。 也许如果我从一个已经有了这个行数的工作簿模板开始，我可能会更容易一些。

编辑：有人指出，我不清楚我在读的数据是从哪里来的。 使用来自多个文本文件的VBA基元读入这些数据。 一个是pipe道分隔，另外两个逗号，而不是文件的scheme有很大的不同。

至于填充数组，这里是如何发生的一个片段。 它看起来很乱，但根据我比较的三个文件的格式，没有其他方法可以使数据匹配。 无论如何，现在我把所有的东西放到大的，大的数组中，这就是我如何填充这些数组。 对arrViLine和arrNonIraLine以及arrIraLine的引用仅仅是将文件的行从其原始pipe道和逗号分隔的格式中parsing出来的数组： 

  If arrViLine(2) = arrIraLine(1) Or arrViLine(2) = arrNonIraLine(1) Then If arrViLine(2) = arrIraLine(1) Then boolVi = True boolIra = True boolNonIra = False If lonMatchCounter <= 999999 Then matchOneArray(lonMatchCounter, 1) = arrViLine(1) matchOneArray(lonMatchCounter, 2) = arrViLine(2) matchOneArray(lonMatchCounter, 3) = arrIraLine(2) matchOneArray(lonMatchCounter, 4) = arrIraLine(3) matchOneArray(lonMatchCounter, 5) = arrViLine(3) matchOneArray(lonMatchCounter, 6) = arrViLine(4) matchOneArray(lonMatchCounter, 7) = arrIraLine(4) matchOneArray(lonMatchCounter, 8) = arrViLine(6) matchOneArray(lonMatchCounter, 9) = arrViLine(5) matchOneArray(lonMatchCounter, 10) = arrViLine(7) matchOneArray(lonMatchCounter, 11) = arrViLine(8) matchOneArray(lonMatchCounter, 12) = arrViLine(9) matchOneArray(lonMatchCounter, 13) = arrViLine(10) matchOneArray(lonMatchCounter, 14) = arrViLine(11) matchOneArray(lonMatchCounter, 15) = arrViLine(12) matchOneArray(lonMatchCounter, 16) = arrIraLine(5) matchOneArray(lonMatchCounter, 17) = arrIraLine(6) matchOneArray(lonMatchCounter, 18) = arrViLine(13) matchOneArray(lonMatchCounter, 19) = arrViLine(14) matchOneArray(lonMatchCounter, 20) = "IRA" matchOneArray(lonMatchCounter, 21) = arrViLine(15) lonMatchCounter = lonMatchCounter + 1 Else lonMatchTwoCounter = lonMatchCounter - 999999 matchTwoArray(lonMatchTwoCounter, 1) = arrViLine(1) matchTwoArray(lonMatchTwoCounter, 2) = arrViLine(2) matchTwoArray(lonMatchTwoCounter, 3) = arrIraLine(2) matchTwoArray(lonMatchTwoCounter, 4) = arrIraLine(3) matchTwoArray(lonMatchTwoCounter, 5) = arrViLine(3) matchTwoArray(lonMatchTwoCounter, 6) = arrViLine(4) matchTwoArray(lonMatchTwoCounter, 7) = arrIraLine(4) matchTwoArray(lonMatchTwoCounter, 8) = arrViLine(6) matchTwoArray(lonMatchTwoCounter, 9) = arrViLine(5) matchTwoArray(lonMatchTwoCounter, 10) = arrViLine(7) matchTwoArray(lonMatchTwoCounter, 11) = arrViLine(8) matchTwoArray(lonMatchTwoCounter, 12) = arrViLine(9) matchTwoArray(lonMatchTwoCounter, 13) = arrViLine(10) matchTwoArray(lonMatchTwoCounter, 14) = arrViLine(11) matchTwoArray(lonMatchTwoCounter, 15) = arrViLine(12) matchTwoArray(lonMatchTwoCounter, 16) = arrIraLine(5) matchTwoArray(lonMatchTwoCounter, 17) = arrIraLine(6) matchTwoArray(lonMatchTwoCounter, 18) = arrViLine(13) matchTwoArray(lonMatchTwoCounter, 19) = arrViLine(14) matchTwoArray(lonMatchTwoCounter, 20) = "IRA" matchTwoArray(lonMatchTwoCounter, 21) = arrViLine(15) lonMatchCounter = lonMatchCounter + 1 End If Else 'arrViLine(2) must = arrNonIraLine(1) boolVi = True boolIra = False boolNonIra = True If lonMatchCounter <= 999999 Then matchOneArray(lonMatchCounter, 1) = arrViLine(1) matchOneArray(lonMatchCounter, 2) = arrViLine(2) matchOneArray(lonMatchCounter, 3) = arrNonIraLine(2) matchOneArray(lonMatchCounter, 4) = arrNonIraLine(3) matchOneArray(lonMatchCounter, 5) = arrViLine(3) matchOneArray(lonMatchCounter, 6) = arrViLine(4) matchOneArray(lonMatchCounter, 7) = arrNonIraLine(5) matchOneArray(lonMatchCounter, 8) = arrViLine(6) matchOneArray(lonMatchCounter, 9) = arrViLine(5) matchOneArray(lonMatchCounter, 10) = arrViLine(7) matchOneArray(lonMatchCounter, 11) = arrViLine(8) matchOneArray(lonMatchCounter, 12) = arrViLine(9) matchOneArray(lonMatchCounter, 13) = arrViLine(10) matchOneArray(lonMatchCounter, 14) = arrViLine(11) matchOneArray(lonMatchCounter, 15) = arrViLine(12) matchOneArray(lonMatchCounter, 16) = arrNonIraLine(4) matchOneArray(lonMatchCounter, 17) = arrNonIraLine(6) matchOneArray(lonMatchCounter, 18) = arrViLine(13) matchOneArray(lonMatchCounter, 19) = arrViLine(14) matchOneArray(lonMatchCounter, 20) = "IRA" matchOneArray(lonMatchCounter, 21) = arrViLine(15) lonMatchCounter = lonMatchCounter + 1 Else lonMatchTwoCounter = lonMatchCounter - 999999 matchTwoArray(lonMatchTwoCounter, 1) = arrViLine(1) matchTwoArray(lonMatchTwoCounter, 2) = arrViLine(2) matchTwoArray(lonMatchTwoCounter, 3) = arrNonIraLine(2) matchTwoArray(lonMatchTwoCounter, 4) = arrNonIraLine(3) matchTwoArray(lonMatchTwoCounter, 5) = arrViLine(3) matchTwoArray(lonMatchTwoCounter, 6) = arrViLine(4) matchTwoArray(lonMatchTwoCounter, 7) = arrNonIraLine(5) matchTwoArray(lonMatchTwoCounter, 8) = arrViLine(6) matchTwoArray(lonMatchTwoCounter, 9) = arrViLine(5) matchTwoArray(lonMatchTwoCounter, 10) = arrViLine(7) matchTwoArray(lonMatchTwoCounter, 11) = arrViLine(8) matchTwoArray(lonMatchTwoCounter, 12) = arrViLine(9) matchTwoArray(lonMatchTwoCounter, 13) = arrViLine(10) matchTwoArray(lonMatchTwoCounter, 14) = arrViLine(11) matchTwoArray(lonMatchTwoCounter, 15) = arrViLine(12) matchTwoArray(lonMatchTwoCounter, 16) = arrNonIraLine(4) matchTwoArray(lonMatchTwoCounter, 17) = arrNonIraLine(6) matchTwoArray(lonMatchTwoCounter, 18) = arrViLine(13) matchTwoArray(lonMatchTwoCounter, 19) = arrViLine(14) matchTwoArray(lonMatchTwoCounter, 20) = "Non-IRA" matchTwoArray(lonMatchTwoCounter, 21) = arrViLine(15) lonMatchCounter = lonMatchCounter + 1 End If End If

你也可以忽略布尔variables，它们在那里提示macros是否应该在下一个循环中读取特定文件的下一行。

编辑：这不是说我有多快的速度写入excel的数据，考虑下面的行是我正在使用的文件的格式的一个例子。

“主文件： 

 Account Number|ID Number|Int Rate|Cum Int|Agreement|Type 12345|111111|.005|.01234|"C"|"IRA" 12346|111112|.005|.02345|"A"|"Non-IRA" 12347|111113|.004|.02345|"B"|"Non-IRA"

匹配文件一： 

 ID Number|Int Rate|Cum Int|Type 111111|.004|.01234|"IRA"

匹配文件二： 

 ID Number|Int Rate|Cum Int|Type 111113|.004|.02345|"Non-IRA"

所以这只是我正在使用的一个小例子。 文本文件和CSV文件按ID号顺序排列。 在上面的示例中，macros将匹配主文件的第一行以匹配文件1，并将来自两个文件的所有字段的数据logging到将输出到Excel电子表格的数组中。 然后，macros读入主文件的下一行并匹配文件1，但是从文件2到下一个循环传送该行。 主人的下一行将没有匹配，并logging在单独的工作簿上。 主文件的最后一行匹配文件二，并被logging到与第一个匹配相同的数组中。

这就是例程的工作原理，但是我所遇到的真正问题是数据写入Excel工作簿的速度。 我目前正在将数据刻录到列中​​。

您不需要集合：只需将工作表中的数据分配到单个变体中，然后将变体分配回新工作表。

为了最小化内存等尝试使用工作表上的UsedRange。 本示例每次复制一列：从1个工作表中将1百万行乘21列复制到另一个工作表（使用Excel 2010 32位）需要35秒 

  Sub getting() Dim var As Variant Dim j As Long Dim dTime As Double dTime = Now For j = 1 To 21 var = Worksheets("Sheet3").UsedRange.Resize(, 1).Offset(0, j - 1).Value2 Worksheets("Sheet1").Range("a1").Resize(UBound(var), UBound(var, 2)).Offset(0, j - 1) = var Next j MsgBox CStr(Now - dTime) End Sub

我试图testing这将有50万行进入一个数组，但得到了一个内存不足的错误。 你没有说你是如何填充你的集合/数组，但我认为你能够做到这一点。 为了演示目的，我用了400k x 21arrays。

一直在使用的部分是，您一次只能写入表格21个单元格。 写入表单是Excel VBA中可以执行的最耗时的工作，因此您需要尽可能减less操作。

为了这个概念的certificate，我读了400k x 21的数据。 我把它们以100k行的增量写到不同的页面上。 为了您的目的，您应该制作您的内存可以处理的最大的块数组。 

 Sub WriteDataToFiles() Dim vaData As Variant Dim vaChunk() As Variant Dim lStep As Long Dim i As Long, j As Long, k As Long Dim wb As Workbook, sh As Worksheet Dim lStart As Long lStart = Timer 'Process in 100,000 row increments lStep = 10 ^ 5 'Fill a big array with a bunch of data FillDataArray vaData 'Show how big the array is Debug.Print UBound(vaData, 1) & " x " & UBound(vaData, 2) 'Create a new workbook to write to Set wb = Workbooks.Add 'loop through the big array in 100k increments For i = LBound(vaData, 1) To UBound(vaData, 1) Step lStep 'dimension a smaller range to hold a subset of the big array ReDim vaChunk(1 To lStep, 1 To 21) 'clean out array 'fill the smaller array with data from big array For j = LBound(vaChunk) To UBound(vaChunk) For k = 1 To 21 vaChunk(j, k) = vaData(i + j - 1, k) Next k Next j 'Add a new sheet Set sh = wb.Worksheets.Add 'Write the small array to the sheet sh.Range("A1").Resize(UBound(vaChunk, 1), UBound(vaChunk, 2)).Value = vaChunk Next i 'See how long it takes Debug.Print Timer - lStart End Sub

从即时窗口： 

 400000 x 21 8.68359375

我悲伤的PC上约9秒将400k行分成四张。 我在每张纸上放了10万张，但我可以放更多。 即使你以100k行的增量工作，你仍然可以把它们放在同一张纸上。 我的代码中不是“A1”，而是需要将块写入下一个单元格，并跟踪下一个单元格的位置。 然后当下一个单元格是> 10 ^ 6行时，您创build一个新的工作表并重新开始。

总而言之，将数据存入可以同时写入工作表的最大二维数组中。 写入越less，代码越快。

你对慢速写入的描述使我怀疑你在使用Collection索引时遇到了O（n ^ 2）的问题。

所以试试这个：而不是像现在这样对集合进行索引： 

 For lonSheetOneCounter = 2 to 999999 outputWorkbook.Worksheets(1).Range(_ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 1).Address & ":" & _ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 21).Address).Value = _ outputCollection.item(lonSheetOneCounter - 1) Next lonSheetOneCounter

尝试枚举它，而不是： 

 lonSheetOneCounter = 2 For each item In outputCollection outputWorkbook.Worksheets(1).Range(_ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 1).Address & ":" & _ outputWorkbook.Worksheets(1).Cells(lonSheetOneCounter, 21).Address).Value = _ item lonSheetOneCounter = lonSheetOneCounter + 1 Next

而且你知道，鉴于这是VBA，而且你正在执行循环主体一百万次，所以本地化你的引用并使用直接范围规范而不是string是不利的： 

 lonSheetOneCounter = 2 Dim ws As Worksheet Set ws = outputWorkbook.Worksheets(1) For each item In outputCollection ws.Range( _ ws.Cells(lonSheetOneCounter, 1), ws.Cells(lonSheetOneCounter, 21) ).Value = item lonSheetOneCounter = lonSheetOneCounter + 1 Next

首先，我认为你正在使用一套错误的工具。 VBA不能很好地处理大量的数据，并且按值写入值非常慢。

最合适的方法是使用logging集从文件中获取数据并将其转储到模板上

我假设：

  • 您的文件与包含代码的工作簿位于相同的文件夹中
  • 有一个名为master.csv（pipe道分隔符）的文件和名为ira.csv和non_ira.csv的文件，两者都用逗号分隔

这就是说，你的程序可以分为三个步骤：

  1. 创build一个schema.ini文件
  2. 使用ActiveX Data Objects库从文件中获取数据
  3. 将数据转储到工作簿

第1步： schema.ini文件

这一步是必需的，因为你的文件没有相同的分隔符。 这一步只需要在与数据相同的文件夹中创build一个名为schema.ini的文件，并粘贴下面的代码： 

 [master.csv] DecimalSymbol=. Format=Delimited(|) ColNameHeader=True [ira.csv] DecimalSymbol=. Format=Delimited(,) ColNameHeader=True [non_ira.csv] DecimalSymbol=. Format=Delimited(,) ColNameHeader=True

这个文件可以用来为你的数据指定不同的属性。 有关更多信息，请参阅此链接

步骤2：使用ActiveX Data Objects库从文件中获取数据

首先，您需要添加对ActiveX数据对象库的引用。 为此，打开VBA编辑器，然后转至Tools > References并检查Microsoft ActiveX Data Objects library 。 在您的数据上使用SQL查询需要执行此步骤。

接下来，您必须编写代码来configuration与数据的连接，如下所示： 

 Private Function CreateConnection(folderPath As String) As ADODB.Connection Dim conStr As String conStr = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Replace(folderPath, "\", "\\") & ";" & _ "Extended Properties=""text;HDR=Yes;IMEX=1;FMT=Delimited"";" Set CreateConnection = New ADODB.Connection CreateConnection.Open conStr End Function

然后你可以编写一个函数来创build一个基于自定义SQL查询的logging集，如下所示： 

 Private Function GetData(cnn As ADODB.Connection, file As String) As ADODB.Recordset Dim strSql As String Const adOpenStatic = 3 Const adLockOptimistic = 3 Const adCmdText = &H1 'You'll need to change this variable to match your needs strSql = "SELECT master.[Account Number], " & _ " master.[ID Number], " & _ " file.[Int Rate], " & _ " file.[Cum Int] " & _ "FROM [master.csv] master INNER JOIN [" & file & ".csv] file ON master.[ID Number] = file.[ID Number]" Set GetData = New Recordset GetData.Open strSql, cnn, adOpenStatic, adLockOptimistic, adCmdText End Function

此函数将使用ID Number作为关键字，返回一个logging集，其中包含master file和file共有的数据

第3步：将数据转储到工作簿

要做到这一点，你可以这样写： 

 Public Sub LoadData() Dim cnn As ADODB.Connection Dim rsIRA As ADODB.Recordset, rsNonIRA As ADODB.Recordset Dim wbk As Workbook Application.Calculation = xlCalculationManual Application.ScreenUpdating = False 'In this example the files and this workbook are in the same folder Set cnn = CreateConnection(ThisWorkbook.Path & "\") Set rsIRA = GetData(cnn, "ira") Set rsNonIRA = GetData(cnn, "non_ira") Set wbk = Workbooks.Open("S:\Some Directory\Template.xlsx") 'Dumps the data from the recordset wbk.Worksheets(1).Range("A2").CopyFromRecordset rsIRA wbk.Worksheets(1).Range("A2").Offset(rsIRA.RecordCount, 0).CopyFromRecordset rsNonIRA Application.ScreenUpdating = True 'Clean up rsIRA.Close rsNonIRA.Close cnn.Close Set rsIRA = Nothing Set rsNonIRA = Nothing Set cnn = Nothing End Sub

我使用您提供的数据样本进行了testing，并且工作正常。 您必须根据您的需求调整代码我认为它会运行得更快，因为它仅处理DB / Excel API，消除了VBA瓶颈

Interesting Posts

VBA“参数不可选” – 不确定如何声明variables

根据多个条件返回其他工作表中的匹配值

（解决）VBAarrays大小重置一次打32767（Excel 2010）

在VBA，Excel中自动创build不同的，可识别的集合

在vba中将数组向下移一位

如何根据Google电子表格中的单元格值返回两个数组之间的数组？

如何用填充在module1 VBA中的数组填充一个列表框

Vba，select一个dynamicmatrix

Excel – 在行中查找值不是错误或空白

子arrays内的近似匹配