VBA Excel总表以某列数据为基础拆分为独立文件的表，也可以拆分为独立的sheet表不导出！！

VBA Excel总表以某列数据为基础拆分为独立文件的表，也可以拆分为独立的sheet表不导出！！

Sub 总表拆分成多个文件工作表()

Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object

Dim k, t, Str As String, i As Long, lc As Long

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Dim iuser

iuser = Environ("username")

ipath = "C:\Users\" & iuser & "\Desktop" & "\已拆分的数据表"

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(ipath) = True Then

FSO.GetFolder(ipath).Delete

Else

MkDir ipath

End If

Arr = Range("A1").CurrentRegion.Value

lc = UBound(Arr, 2)

Set Rng = Rows(1)

Set Dic = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(Arr)

Str = Arr(i, 1)

' Str = Left(Arr(i, 1), Len(Arr(i, 1)) - 2) '截取某列的关键字，不截取则用，arr(i,1)

If Not Dic.Exists(Str) Then

Set Dic(Str) = Cells(i, 1).Resize(, lc)

Else

Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc))

End If

Next

k = Dic.Keys

t = Dic.Items

On Error Resume Next

With Sheets

For i = 0 To Dic.Count - 1

Set Sht = .Item(k(i))

If Sht Is Nothing Then

.Add(after:=.Item(.Count)).Name = k(i)

Set Sht = ActiveSheet

Else

Sht.Cells.Clear '

End If

Rng.Copy Sht.Range("A1")

t(i).Copy Sht.Range("A2")

Sht.Cells.EntireColumn.AutoFit

Set Sht = Nothing

Next

End With

Sheets(1).Activate

For Each Sht In ThisWorkbook.Sheets

Set sht2 = Workbooks.Add

Sht.Copy sht2.Sheets(1)

sht2.Sheets(1).Name = "表格名称" '每张表的表格名称，自行修改，去掉这句则以关键字为sheet表格名称

For i = sht2.Sheets.Count To 2 Step -1

Application.DisplayAlerts = False

sht2.Sheets(i).Delete

Next

sht2.SaveAs ipath & "\" & Sht.Name & ".xlsx"

sht2.Close

Next

Dim c&

For c = Sheets.Count To 2 Step -1

Sheets(c).Delete

Next

MsgBox "数据处理完成" & Chr(10) & "数据保存在电脑桌面!!" & Chr(10) & "文件路径：" & ipath

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

以下为只把总表拆分成单独的sheet表格，不导出文件！！

Sub 总表拆分成多个sheet表格()

Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object

Dim k, t, Str As String, i As Long, lc As Long

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Arr = Range("A1").CurrentRegion.Value

lc = UBound(Arr, 2)

Set Rng = Rows(1)

Set Dic = CreateObject("Scripting.Dictionary")

For i = 2 To UBound(Arr)

Str = Arr(i, 1)

' Str = Left(Arr(i, 1), Len(Arr(i, 1)) - 2) '截取关键字，不截取则用，arr(i,1)

If Not Dic.Exists(Str) Then

Set Dic(Str) = Cells(i, 1).Resize(, lc)

Else

Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc))

End If

Next

k = Dic.Keys

t = Dic.Items

On Error Resume Next

With Sheets

For i = 0 To Dic.Count - 1

Set Sht = .Item(k(i))

If Sht Is Nothing Then

.Add(after:=.Item(.Count)).Name = k(i)

Set Sht = ActiveSheet

Else

Sht.Cells.Clear '

End If

Rng.Copy Sht.Range("A1")

t(i).Copy Sht.Range("A2")

Sht.Cells.EntireColumn.AutoFit

Set Sht = Nothing

Next

End With

Sheets(1).Activate

MsgBox "数据处理完成"

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub