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 Connection和SQL语句来读取和写入工作表。将Excel文件作为数据库处理通常比使用Excel Automation API快得多。

通过工具 - ＆gt; 引用... ，添加对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

然后，您可以获得一系列独特的TRRoom：

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及更高版本阻止执行修改数据（INSERT，UPDATE，DELETE）的SQL语句对Excel工作表。但这通常可以通过调用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都会逐渐增加。

如果主表上有一些需要保留的进一步排序，则在排序TRRoom

之前添加一个虚拟列并使用1,2,3等自动填充它

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

VBA for Excel资源不足

4 个答案: