如何使用VBA快速拆分大型工作表，采用filter方法！

zhigangchen

我在第一篇贴子里介绍了工作表拆分的方法，但是这种方法并不是最好的。特别是在拆分大型工作表时，比如工作表有几十万行，这时往往会卡死。于是，我想到如果能够模仿平时我们筛选过后，将结果复制到一个新的工作表的方法，是不是会更快些。经过测试，确实是这样的，时间只需要原来的几十分之一。以下是代码：
Sub 快速拆分工作表()
Dim t, d, arr As Variant, x&, k&, col_name$, col_num%, rows_start%, mypath$, sheet_name$
ThisWorkbook.Sheets(1).Activate
sheet_name = Application.InputBox("请输入要拆分的表格名称，如sheet1", 表格名称)
col_name = Application.InputBox("请输入拆分依据成员所在的列，如a", 输入列名称)
col_num = Range(col_name & 1).Column
rows_start = Application.InputBox("请输入标题行下开始的第一行号，如2", 输入开始行号)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim min
min = Timer
Set d = CreateObject("scripting.dictionary")
k = Sheets(sheet_name).UsedRange.CurrentRegion.Rows.Count - rows_start + 1
arr = Range(col_name & rows_start & ":" & col_name & k)
For x = rows_start + 1 To UBound(arr)
d(arr(x, 1)) = ""
Next x
If d.exists("") Then
d.Remove ""
End If
For Each t In d.keys
Workbooks.Add
mypath = ThisWorkbook.Path & "\" & sheet_name & "_" & "拆分出的表格\"
If Dir(mypath, vbDirectory) = "" Then
MkDir mypath
End If
Dim workbook_path As String
workbook_path = ThisWorkbook.Path & "\" & sheet_name & "_" & "拆分出的表格\" & _
sheet_name & "_" & t & ".xlsx"
ActiveSheet.Name = t
ThisWorkbook.Sheets(sheet_name).Rows(rows_start - 1).AutoFilter Field:=col_num, Criteria1:=t
ThisWorkbook.Sheets(sheet_name).UsedRange.Copy ActiveSheet.Cells(1, 1)
ActiveWorkbook.SaveAs workbook_path
ActiveWorkbook.Close
ThisWorkbook.Activate
Next t
Application.ScreenUpdating = True
ThisWorkbook.Sheets(sheet_name).Rows(rows_start - 1).AutoFilter
MsgBox "拆分完工作表，一共用时" & Timer - min & "秒！"
Application.Calculation = xlCalculationAutomatic
End Sub

xueliang1215

点击运行提示下标越界

lisga1103

太好用了！真棒！佩服之至！