VBA for Excel 资源不足

Question

我有一个 Excel 工作表，我需要根据一列的值将其分成几个较小的工作表。该代码运行良好，但是当它超过第 10k 行时会耗尽资源。

我认为问题出在我试图找到最后一行时，所以我想知道是否有更有效的解决方法来避免内存问题。或者也许这不是问题所在？

代码如下。

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

我建议使用 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 的一些参考资料，请参阅 here。

---

更新

AFAIK、Excel 2013 及更高版本阻止执行​​针对 Excel 工作表修改数据的 SQL 语句（INSERT、UPDATE、DELETE）。但这通常可以替换为调用Range.CopyFromRecordet 方法：

Do Until rs.EOF
    Dim sql As String
    sql = _
        "SELECT * " & _
        "FROM [Master$] " & _
        "WHERE F28 = """ & rs!F28 & """"
    Worksheets(rs!F28).Range.CopyFromRecordset conn.Execute(sql)
    rs.MoveNext
Loop

Answer 2

我在包含 26 个不同工作表的 20,000 行数据集上对此进行了测试，它在我的机器上大约 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 时找到相关选项卡上的最后一行。之后lastRowNumber 和localLastRowNumber 将同步增加。

如果您需要保留主表上的一些进一步排序，则添加一个虚拟列并自动填充 1、2、3 等，然后再对 TRRoom 进行排序

Answer 4

（不是解决方案）

如果您运行以下命令，您会在即时窗口中看到什么：

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