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

我有一个800k行和150列的电子表格。 我正在尝试基于列的内容创build新的工作表。 所以，例如，如果Y列有许多元素（“alpha”，“beta”，“gamma”等），那么我想创build名为“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

您可以在另一篇文章“ 用于将数据复制并粘贴到另一个工作表的macros ”中引用修改后的子例程。

 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