Question

我有一个包含800k行和150列的电子表格。我试图根据列的内容创建新的工作表。因此，例如，如果列Y有许多元素（＆＃34; alpha＆＃34;，＆＃34; beta＆＃34;，＆＃34; gamma＆＃34;等等），那么我想创建新工作表名为＆＃34; alpha＆＃34;，＆＃34; beta＆＃34;，＆＃34; gamma＆＃34;其中只包含原始行中具有相应字母的行。我找到了两个适用于较小电子表格的脚本，但由于此特定电子表格的大小，他们无法正常工作。

以下是我尝试过的两个脚本：

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

这会返回＆＃34;溢出＆＃34;

我尝试过的其他代码：

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

返回错误＆＃34; excel没有足够的资源＆＃34;。

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

Answer 1

您可以在另一篇文章＆＃39; Macro for copying and pasting data to another worksheet＆＃39;中参考修改后的子程序。

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

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

1 个答案: