时间戳

首页 > 解决方案 > 性能问题“内存不足”Macro vba Excel - 解析数据

excel - 性能问题“内存不足”Macro vba Excel - 解析数据

问题描述

我已经构建了一些代码，应该根据唯一值解析数据，然后为每个唯一值创建一个新的工作表。我的初始表有 10 列和大约 25K 行。该代码适用于大约 ca。8500 行。上面，我收到错误消息

内存不够等等...

Excel 64bits 无法安装在我们的工作机器上...有什么解决方法的想法吗？我只需要这段代码在 3 小时内运行，这将是一个巨大的胜利！谢谢！

Sub Split_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim OutPut As Integer



 'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
 'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="10", Type:=1)
Set ws = Worksheets("Import") 'change worhseet name when necessary
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:J14"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 3 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next
Application.ScreenUpdating = False
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear

For i = 3 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit

Next

ws.AutoFilterMode = False
ws.Activate
Sheets("Instructions").Select

OutPut = MsgBox("Data successfully parsed", vbInformation, "Confirmation")
End Sub

标签： excelvbaparsing

解决方案

这对我有用：

编辑 - 更新以考虑 >1 标题行

Sub Split_data()
    
    Const NUM_HEADER_ROWS As Long = 14
    Dim ws As Worksheet, wb As Workbook, dict As Object
    
    Dim tbl As Range, rngHeaders As Range, arr, r As Long, k, vcol, v
    Dim rngData As Range
    
    Set wb = ActiveWorkbook 'or Thisworkbook
    Set ws = Worksheets("Import")
    
    Set tbl = ws.Range("A1").CurrentRegion        'the whole table
    Set rngHeaders = tbl.Resize(NUM_HEADER_ROWS)  'all the headers
    
    Set rngData = tbl.Offset(NUM_HEADER_ROWS) _
                  .Resize(tbl.Rows.Count - NUM_HEADER_ROWS) 'just the data
    
    vcol = Application.InputBox(prompt:="Which column on '" & ws.Name & _
                                "' would you like to filter by?", _
                                Title:="Filter column", Default:="10", Type:=1)
    
    'collect all the unique values from the selected column
    Set dict = CreateObject("scripting.dictionary")
    arr = ws.Range(ws.Cells(rngData.Rows(1).Row, vcol), _
                   ws.Cells(Rows.Count, vcol).End(xlUp)).Value
    For r = 1 To UBound(arr, 1)
        v = arr(r, 1)
        If Len(v) > 0 And Not dict.Exists(v) Then dict.Add v, True
    Next r
    
    'warn if lots of sheets will be created
    If dict.Count > 30 Then
        If MsgBox("This will create " & dict.Count & " new sheets.  Continue?", _
                  vbQuestion + vbYesNo, Title:="Continue?") <> vbYes Then Exit Sub
    End If
    
    Application.ScreenUpdating = False
    'create sheets and filter/copy data
    For Each k In dict
        Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
        rngHeaders.Copy ws.Range("a1")
        rngData.Parent.Rows(NUM_HEADER_ROWS).AutoFilter field:=vcol, Criteria1:=k
        rngData.SpecialCells(xlCellTypeVisible).Copy ws.Cells(NUM_HEADER_ROWS + 1, 1)
        tbl.Parent.ShowAllData
    Next
    
    MsgBox "Data successfully parsed", vbInformation, "Confirmation"

End Sub

推荐阅读