Блог

Я создал некоторый код, который должен анализировать данные в соответствии с уникальным значением, а затем создавать новый рабочий лист для каждого уникального значения. В моей исходной таблице 10 столбцов и около 25 тыс. строк. Код хорошо работает до 8500 строк. Выше я получаю сообщение об ошибке

недостаточно памяти и т. Д…

64-битный Excel не может быть установлен на наших рабочих компьютерах… Есть идеи по обходному пути? Мне просто нужно, чтобы этот код выполнялся менее чем за 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) amp; ""
    If Not Evaluate("=ISREF('" amp; myarr(i) amp; "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) amp; ""
    Else
        Sheets(myarr(i) amp; "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" amp; titlerow amp; ":A" amp; lr).EntireRow.Copy Sheets(myarr(i) amp; "").Range("A1")
    Sheets(myarr(i) amp; "").Columns.AutoFit

Next

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

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

Это работает для меня:

РЕДАКТИРОВАТЬ — обновлено для учета> 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 '" amp; ws.Name amp; _
                                "' 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 " amp; dict.Count amp; " 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