vba - 根据 LARGE 电子表格的列数据生成新工作表

Question

我有一个包含 800k 行和 150 列的电子表格。我正在尝试根据列的内容创建新的工作表。因此，例如，如果 Y 列有很多元素(“alpha”、“beta”、“gamma”等)，那么我想创建名为“alpha”、“beta”、“gamma”的新工作表，其中仅包含原始行中具有这些相应字母的行。我发现了两个适用于较小电子表格的脚本，但由于这个特定电子表格的大小，它们 不工作 .

这是我尝试过的两个脚本:

Sub parse_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
vcol = 1       
Set ws = Sheets("Sheet1")       
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"           
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 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
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 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
End Sub

这将返回“溢出”

我尝试过的其他代码:

Sub columntosheets()

Const sname As String = "VOTERFILE_WITHABSENTEEINFORMATI" 'change to whatever starting sheet
Const s As String = "O" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
    Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
    .Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
    a = .Cells(cc).Resize(rws + 1, 1)
    p = 2
    For i = 2 To rws + 1
        If a(i, 1) <> a(p, 1) Then
            If d(a(p, 1)) <> 1 Then
                Sheets.Add.Name = a(p, 1)
                .Cells(1).Resize(, cls).Copy Cells(1)
                .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
            End If
            p = i
        End If
    Next i
    Application.DisplayAlerts = False
    .Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End With
Sheets(sname).Activate

End Sub

返回错误“excel没有足够的资源”。

是否可以在我的硬件上做我想做的事？

Answer 1

您可以引用另一篇文章中修改的子程序'Macro for copying and pasting data to another worksheet '。

Sub CopySheet()

Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long

Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on

LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row

Set wsCrit = Worksheets.Add

' column G has the criteria eg project ref
wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit

     wsAll.Copy Before:=Sheets("All")
     ActiveSheet.Name = wsCrit.Range("A2")
     Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=wsCrit.Range("A1:A2"), _
     Unique:=False
     wsCrit.Rows(2).Delete

Next I

Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True

End Sub