多字段分类汇总-类数据透视表格式的汇总-加载宏.doc

实例21：多字段分类汇总类数据透视表格式的汇总加载宏/dispbbs.asp?boardid=2&replyid=570898&id=195189&page=1&skin=0&Star=3Private Sub UserForm_Initialize() UserForm6.Hide With Sheets(UserForm6.ComboBox_DataShName.Value) arr = .Range(.Cells(1, 1), .Cells(1, .iv1.End(xlToLeft).Column) End With arr = Application.Index(arr, 1, 0) ListBox_Column.List = arr ComboBox_Row.List = arr ComboBox_field.List = arr ComboBox_Mode.AddItem 求和 ComboBox_Mode.AddItem 计数End SubPrivate Sub CommandButton1_Click() Dim sql$ UserForm7.Hide Set cnn = CreateObject(ADODB.connection) cnn.Open Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source= & ActiveWorkbook.FullName sqlmode = IIf(ComboBox_Mode.Value = 求和, sum, count) For j = 0 To ListBox_Column.ListCount - 1 If ListBox_Column.Selected(j) Then columntitle = columntitle & & ListBox_Column.List(j) & , End If Next columntitle = Left(columntitle, Len(columntitle) - 1) sql = transform & sqlmode & ( & & ComboBox_field & ) select & columntitle & from & UserForm6.ComboBox_DataShName.Value & $ group by & columntitle & pivot & ComboBox_Row & Set temp = cnn.Execute(sql) For i = 1 To temp.fields.Count Cells(TextBox_Row.Value, i) = temp.fields(i - 1).Name Next Range(TextBox_Column.Value & TextBox_Row.Value + 1).CopyFromRecordset temp cnn.Close: Set cnn = NothingEnd Sub使用方法：工具加载宏浏览，找到下载的“分表合表及分类汇总.xla”，确定，确定，则在菜单上会增加一项“分表合表及分类汇总”，下面包含六个菜单项： 单工作表拆分为多工作表 单工作表拆分成多工作簿 多工作表复制为多工作簿 当前工作簿多工作表合并 多工作簿工作表合并到当前表 多字段分类汇总类数据透视表格式卸载方法：工具加载宏，去掉“分表合表及分类汇总”前的对勾，确定即可。点击浏览该文件06-11-14Public arrPublic arr1Public arr2Public arPublic ar1Sub auto_open() 加载宏 * by 赖效莹 Dim CtrButton As CommandBarControl Dim Btn(5) As CommandBarControl Set CtrButton = Application.CommandBars(1).Controls.Add(Type:=10, before:=11) With CtrButton .Caption = 分表合表及分类汇总 Set Btn(0) = CtrButton.Controls.Add(Type:=1) Btn(0).Caption = 单工作表拆分为多工作表 Btn(0).OnAction = 将当前活动的工作表拆分成多个工作表 Set Btn(1) = CtrButton.Controls.Add(Type:=1) Btn(1).Caption = 单工作表拆分成多工作簿 Btn(1).OnAction = 将当前活动的工作表拆分成若干工作簿 Set Btn(2) = CtrButton.Controls.Add(Type:=1) Btn(2).Caption = 多工作表复制为多工作簿 Btn(2).OnAction = 将当前活动工作簿的若干工作表拆分成若干工作簿 Set Btn(3) = CtrButton.Controls.Add(Type:=1) Btn(3).Caption = 当前工作簿多工作表合并 Btn(3).OnAction = 将一个工作簿的若干工作表任意合并成一张工作表 Set Btn(4) = CtrButton.Controls.Add(Type:=1) Btn(4).Caption = 多工作簿工作表合并到当前表 Btn(4).OnAction = ADO_将同路径下的多张工作簿中的工作表合并到当前活动的工作表 Set Btn(5) = CtrButton.Controls.Add(Type:=1) Btn(5).Caption = 多字段分类汇总类数据透视表格式 Btn(5).OnAction = ADO_多字段分类汇总 End With End SubSub auto_close() 卸载宏 Application.CommandBars(1).Controls(分表合表及分类汇总).DeleteEnd SubADO合并文件并去除表中链接及空行Sub ADO_将同路径下的多张工作簿中的工作表合并到当前活动的工作表() UserForm5.Show (0)End SubSub ADO_多字段分类汇总() UserForm6.Show (0)End Sub * by 赖效莹 Sub 将一个工作簿的若干工作表任意合并成一张工作表() * by 彭希仁 UserForm1.Show (0)End SubSub 另类分类汇总() UserForm2.Show (0)End SubSub 将当前活动的工作表拆分成若干工作簿() UserForm3.Show (0)End SubSub 将当前活动的工作表拆分成多个工作表() UserForm4.Show (0)End SubSub 将同路径下的多张工作簿中的工作表合并到当前活动的工作表() Application.ScreenUpdating = False Dim lj, dirname, nm Dim a As Long Dim i As Long lj = ActiveWorkbook.Path nm = ActiveWorkbook.Name dirname = Dir(lj & *.xls) Do While dirname If dirname nm Then Workbooks.Open Filename:=lj & & dirname a = Sheets.Count 读当前工作簿中的所有的工作表 Workbooks(nm).Activate For i = 1 To a 复制新打开的工作簿的第一个工作表的已用区域到rng Workbooks(dirname).Sheets(i).UsedRange.Copy Range(a65536).End(xlUp).Offset(1, 0) Next Workbooks(dirname).Close False End If dirname = Dir LoopEnd SubSub 将同路径下的多张工作簿中的工作表合并为当前活动工作簿的很多张工作表() Application.ScreenUpdating = False Dim lj, dirname, nm Dim a As Long Dim i As Long lj = ActiveWorkbook.Path nm = ActiveWorkbook.Name dirname = Dir(lj & *.xls) Do While dirname If dirname nm Then Workbooks.Open Filename:=lj & & dirname, UpdateLinks:=0 a = Sheets.Count 读当前工作簿中的所有的工作表 For i = 1 To a Workbooks(dirname).Activate If IsSheetEmpty = IsEmpty(Sheets(i).UsedRange) Then Sheets(i).Copy before:=Workbooks(nm).Sheets(1) 不为空的工作表进行合并 Next Workbooks(dirname).Close False End If dirname = Dir LoopEnd SubSub 将当前活动工作簿的若干工作表拆分成若干工作簿() Application.ScreenUpdating = False Dim lj, dirname, nm Dim a As Long Dim i As Long msg = MsgBox(当前工作簿中的工作表将产生为当前路径下的同名工作簿, vbOKCancel) If msg = vbOK Then lj = ActiveWorkbook.Path nm = ActiveWorkbook.Name For i = 1 To Sheets.Count Workbooks(nm).Activate sm = Sheets(i).Name y = sm & .xls Workbooks.Add ActiveWorkbook.SaveAs Filename:=lj & & y Workbooks(nm).Activate If IsSheetEmpty