楼主
LOGO |
说明：通过对话框确定标题行以及拆分列来将总表数据拆分成多个明细表(借助对话框来确定分拆列以及标题行，通用性较好 )
适用范围：数据从最左列开始（即始于A列),单标题行
缺点：速度不快，用数组或者ADO进行拆分会更快
限于水平，有错的地方还请指正。
VBA代码如下：
- Sub 以指定列拆总表()
- Dim 分拆列 As Range, 分拆列号 As Integer, 起始行 As Range, 起始行号 As Integer, 行号 As Integer
- Dim Dic As Object, sht As Worksheet, i As Integer, 数据, arr, 结束行号 As Integer
- Set Dic = CreateObject("scripting.dictionary")
- On Error Resume Next
- Set 分拆列 = Application.InputBox("请点击拆分列内任意一单元格", "确认拆分列", , , , , , 8)
- If 分拆列 Is Nothing Then Exit Sub
- Set 起始行 = Application.InputBox("请点击标题行内任意一单元格", "确认标题行", , , , , , 8)
- If 起始行 Is Nothing Then Exit Sub
- 分拆列号 = 分拆列.Column
- 起始行号 = 起始行.Row
- 结束行号 = Cells(Rows.Count, 分拆列号).End(xlUp).Row
- Application.ScreenUpdating = False
- Application.Calculation = xlCalculationManual
- Application.DisplayAlerts = False
- For Each sht In Worksheets
- If sht.Name <> ActiveSheet.Name Then sht.Delete '删除其他表只保留当前数据表
- Next
- With ActiveSheet
- If TypeName(.Cells(起始行号 + 1, 分拆列号).Value) = "Date" Then
- .Columns(分拆列号).NumberFormatLocal = "yyyy-mm-dd"
- End If
- 数据 = Range(Cells(起始行号 + 1, 分拆列号), Cells(结束行号, 分拆列号))
- For 行号 = 1 To UBound(数据) '借助字典建立不重复的筛选条件
- If Len(数据(行号, 1)) > 0 Then
- Dic(数据(行号, 1)) = ""
- End If
- Next
- arr = Dic.keys
- With 起始行
- For i = 0 To UBound(arr)
- .AutoFilter Field:=分拆列号, Criteria1:=arr(i) & ""
- Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = CStr(arr(i))
- .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(CStr(arr(i))).[a1] '自动筛选，并复制到新建的表中
- Worksheets(CStr(arr(i))).Columns.AutoFit
- Next i
- .AutoFilter
- End With
- .Activate
- End With
- Application.ScreenUpdating = True
- Application.Calculation = xlCalculationAutomatic
- Application.DisplayAlerts = True
- End Sub
附件如下：
 以指定列拆分总表.rar
|