按指定列自定义拆表

  • A+
所属分类:好好学习

自定义拆分工作表,可根据指定列拆分为工作表或工作薄:

VBA

Sub 自定义拆表()
Dim irow, irow1, i, j As Integer
Dim H As New Collection
Dim sht As Worksheet
Dim A
Dim ICol

Set A = ActiveCell
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Sheets
If sht.Name <> "总表" Then sht.Delete '删除所有分表
Next
Sheets("总表").Copy before:=Sheets(1) '加入新表来操作,以防破坏原数据中的公式或格式
ICol = Application.InputBox("请输入所要参考拆分的列:(如按C列分请输入3)", "提示:", "3", Type:=1)
If ICol = "" Then Exit Sub
Fneiwai = Application.InputBox("请确定是表内还是表外,A为表外(工作簿),B为表内(工作表)", "提示:", "B")
If Fneiwai = "" Then Exit Sub

On Error Resume Next
With Sheets("总表 (2)")
irow = .[a1].CurrentRegion.Rows.Count
For i = 2 To irow
.Cells(i, ICol) = "'" & .Cells(i, ICol) '在原工作表生成文本符号
Next
For i = 2 To irow
H.Add .Cells(i, ICol), CStr(.Cells(i, ICol))
Next '建立一个不重复的筛选条件

If Fneiwai = "A" Then '表外分开
path = Application.ActiveWorkbook.path
For i = 1 To H.Count
.Cells.AutoFilter field:=ICol, Criteria1:=H(i)
Set Nw = Workbooks.Add
.[a1].CurrentRegion.Copy [a1] '自动筛选,并复制到新建的表中
irow1 = [a1].CurrentRegion.Rows.Count
For t = 1 To [a1].CurrentRegion.Columns.Count
Cells(1, t).ColumnWidth = .Cells(1, t).ColumnWidth
Next t '复制列宽
For j = 2 To irow1
Cells(j, ICol) = Right(Cells(j, ICol), Len(Cells(j, ICol))) '消除新工作表文本符号
Next j
Nw.SaveAs Filename:=path & "\" & H(i) & ".xlsx"
Nw.Close True
.Cells.AutoFilter
Next i

ElseIf Fneiwai = "B" Then '表内分开
For i = 1 To H.Count
.Cells.AutoFilter field:=ICol, Criteria1:=H(i)
Sheets.Add(after:=Sheets(Sheets.Count)).Name = H(i)
.[a1].CurrentRegion.Copy Sheets(CStr(H(i))).[a1] '自动筛选,并复制到新建的表中
irow1 = [a1].CurrentRegion.Rows.Count
For t = 1 To [a1].CurrentRegion.Columns.Count
Cells(1, t).ColumnWidth = .Cells(1, t).ColumnWidth
Next t '复制列宽
For j = 2 To irow1
Cells(j, ICol) = Right(Cells(j, ICol), Len(Cells(j, ICol))) '消除新工作表文本符号
Next j
.Cells.AutoFilter
Next i
End If

.Delete '操作表此时已多余,故删除
End With

A.Parent.Activate '激活汇总表的原来激活的单元格
A.Activate

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "拆分完毕!"
End Sub

发表评论

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: