VBA for Excel正在耗尽资源

我有一个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

---

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

我在一个20000行的数据集上测试了这一点，共有26个不同的工作表，在我的机器上大约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

子填充单元（）
将ws设置为工作表
将wsMaster设置为工作表
暗淡的rngFound As范围
Dim rngCopy As范围
Dim lCalc As XLC计算
Dim strFind As字符串
Dim strFirst作为字符串
设置wsMaster=图纸（“主图纸”）
应用
lCalc=.计算
.Calculation=xlCalculationManual
.EnableEvents=False
.ScreenUpdate=False
以
返回CleanExit时出错
对于每个ws-In表单
如果UCase（左（ws.Name，3））=“TR-”，则
strFind=Mid（ws.Name，4）
带有wsMaster.Columns（“AB”）
设置rngFound=.Find（strFind、xlValues、xlWhole）
如果不是，那么rngFound什么都不是
strFirst=rngFound.Address
设置rngCopy=rngFound
做
设置rngCopy=Union（rngCopy，rngFound）
设置rngFound=.Find（strFind、rngFound、xlValues、xlWhole）
在rngFound.Address strFirst时循环
rngCopy.EntireRow.Copy
ws.Cells（ws.Cells.Find（“*”，ws.Range（“A1”），SearchDirection:=xlPrevious.Row+1，“A”）.paste特殊xlpasteValue
如果结束
以
如果结束
下一个ws
清洁出口：
应用
.CutCopyMode=False
.计算=lCalc
.EnableEvents=True
.ScreenUpdate=True
以
如果错误号为0，则
MsgBox错误描述，“错误：&错误号”
呃，明白了
如果结束
设置ws=Nothing
设置wsMaster=Nothing
设置rngFound=Nothing
设置rngCopy=Nothing
端接头

我在一个20000行的数据集上测试了这一点，共有26个不同的工作表，在我的机器上大约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

子填充单元（）
将ws设置为工作表
将wsMaster设置为工作表
暗淡的rngFound As范围
Dim rngCopy As范围
Dim lCalc As XLC计算
Dim strFind As字符串
Dim strFirst作为字符串
设置wsMaster=图纸（“主图纸”）
应用
lCalc=.计算
.Calculation=xlCalculationManual
.EnableEvents=False
.ScreenUpdate=False
以
返回CleanExit时出错
对于每个ws-In表单
如果UCase（左（ws.Name，3））=“TR-”，则
strFind=Mid（ws.Name，4）
带有wsMaster.Columns（“AB”）
设置rngFound=.Find（strFind、xlValues、xlWhole）
如果不是，那么rngFound什么都不是
strFirst=rngFound.Address
设置rngCopy=rngFound
做
设置rngCopy=Union（rngCopy，rngFound）
设置rngFound=.Find（strFind、rngFound、xlValues、xlWhole）
在rngFound.Address strFirst时循环
rngCopy.EntireRow.Copy
ws.Cells（ws.Cells.Find（“*”，ws.Range（“A1”），SearchDirection:=xlPrevious.Row+1，“A”）.paste特殊xlpasteValue
如果结束
以
如果结束
下一个ws
清洁出口：
应用
.CutCopyMode=False
.计算=lCalc
.EnableEvents=True
.ScreenUpdate=True
以
如果错误号为0，则
MsgBox错误描述，“错误：&错误号”
呃，明白了
如果结束
设置ws=Nothing
设置wsMaster=Nothing
设置rngFound=Nothing
设置rngCopy=Nothing
端接头

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

通过工具->引用…，添加对

Microsoft ActiveX Data Objects 2.8库

（或计算机上安装的最新版本）的引用。然后，以下代码将为您提供到当前工作簿的连接：

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

然后，您可以获得一个独特的会议室列表：

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的一些参考资料，请参阅

---

更新

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

---

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

通过工具->引用…，添加对

Microsoft ActiveX Data Objects 2.8库

（或计算机上安装的最新版本）的引用。然后，以下代码将为您提供到当前工作簿的连接：

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

然后，您可以获得一个独特的会议室列表：

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的一些参考资料，请参阅

---

更新

AFAIK、Excel 2013及更高版本阻止执行修改数据的SQL语句（

INSERT

，

UPD