Excel的VBA资源不足

我有一个Excel工作表，我需要分成几个较小的工作表基于一列的价值。 代码工作得很好，但是当它超过第10k行时耗尽资源。

我认为问题是当我试图find最后一行，所以我想知道是否有一个更有效的解决方法，以避免内存问题。 或者也许这不是问题呢？

代码如下。

Sub Fill_Cells() Dim masterSheet As Worksheet Dim masterSheetName As String Dim TRRoom As String, tabName As String Dim lastRowNumber As Long Dim j As Long Application.ScreenUpdating = False masterSheetName = "Master" Set masterSheet = Worksheets(masterSheetName) lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row j = 4 For Each c In masterSheet.Range("AB4:AB" & lastRowNumber).Cells TRRoom = c.Value tabName = "TR-" & TRRoom localLastRowNumber = Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row insertRow = localLastRowNumber + 1 Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value j = j + 1 Next End Sub 

如果有人能帮助我，我将不胜感激。

Answer 1

我会build议使用ADODB连接和SQL语句读取和写入工作表。 将Excel文件作为数据库来处理通常要比通过Excel自动化API处理快得多。

添加对Microsoft ActiveX Data Objects 2.8 Library的引用。 然后下面的代码会给你一个连接到当前的工作簿：

 Dim conn As New Connection With conn .Provider = "Microsoft.ACE.OLEDB.12.0" .ConnectionString = "Data Source=""" & ActiveWorkbook.FullName & """;" & _ "Extended Properties=""Excel 12.0;HDR=No;""" 'If you're running a version of Excel earlier than 2007, the connection string should look like this: '.ConnectionString = "Data Source=""" & ActiveWorkbook.FullName & """;" & _ ' "Extended Properties=""Excel 8.0;HDR=No;""" .Open End With 

然后，你可以得到一个独特的TRRooms列表：

 Dim rs As Recordset Set rs = conn.Execute("SELECT DISTINCT F28 FROM [Master$]") 'Field F28, because if you specify that your range does not have header rows (HDR=No 'in the connection string) ADODB will automatically assign field names for each field 'Column AB is the 28th column in the worksheet 

并将相关的行插入到相应的工作表中：

 Do Until rs.EOF Dim trroom As String trroom = rs!F28 conn.Execute _ "INSERT INTO [TR-" & trroom & "$] " & _ "SELECT * " & _ "FROM [Master$] " & _ "WHERE F28 = """ & trroom & """" rs.MoveNext Loop 

看到这里有关ADODB的一些参考。

Answer 2

我使用26个不同的工作表对20,000行数据集进行了testing，并在我的机器上完成了大约20秒，没有错误。 让我知道这是否适合你。

 Sub Fill_Cells() Dim ws As Worksheet Dim wsMaster As Worksheet Dim rngFound As Range Dim rngCopy As Range Dim lCalc As XlCalculation Dim strFind As String Dim strFirst As String Set wsMaster = Sheets("Master") With Application lCalc = .Calculation .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False End With On Error GoTo CleanExit For Each ws In Sheets If UCase(Left(ws.Name, 3)) = "TR-" Then strFind = Mid(ws.Name, 4) With wsMaster.Columns("AB") Set rngFound = .Find(strFind, , xlValues, xlWhole) If Not rngFound Is Nothing Then strFirst = rngFound.Address Set rngCopy = rngFound Do Set rngCopy = Union(rngCopy, rngFound) Set rngFound = .Find(strFind, rngFound, xlValues, xlWhole) Loop While rngFound.Address <> strFirst rngCopy.EntireRow.Copy ws.Cells(ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious).Row + 1, "A").PasteSpecial xlPasteValues End If End With End If Next ws CleanExit: With Application .CutCopyMode = False .Calculation = lCalc .EnableEvents = True .ScreenUpdating = True End With If Err.Number <> 0 Then MsgBox Err.Description, , "Error: " & Err.Number Err.Clear End If Set ws = Nothing Set wsMaster = Nothing Set rngFound = Nothing Set rngCopy = Nothing End Sub 

Answer 3

在TRRoom列上对主表单（或其副本）进行TRRoom 。 同一个TRRoom所有条目将被分组在一起。

对于每个TRRoom ，只需要在TRRoom的第一次出现时在相关选项卡上查找最后一行。 之后， lastRowNumber和localLastRowNumber都将相互增加。

如果您需要保留在主表单上的其他订单，请在sortingTRRoom之前添加一个虚拟列并使用1,2,3等自动填充

Answer 4

（不是解决scheme）

如果你运行下面的内容，你会在直接窗口看到什么：

 Sub Fill_Cells() Dim masterSheetName As String Dim masterSheet As Excel.Worksheet Dim TRRoom As String Dim tabName As String Dim lastRowNumber As Long Dim j As Long j = 4 Excel.Application.ScreenUpdating = False masterSheetName = "Master" Set masterSheet = Excel.ThisWorkbook.Worksheets(masterSheetName) lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row For Each cell In masterSheet.Range("AB4:AB" & lastRowNumber).Cells TRRoom = c.Value tabName = "TR-" & TRRoom localLastRowNumber = Excel.ThisWorkbook.Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Debug.Print localLastRowNumber '<<<<<interested to see what values are getting assigned here by printing the values to the immediate window. insertRow = localLastRowNumber + 1 Excel.ThisWorkbook.Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value j = j + 1 Next cell End Sub