【#文档大全网# 导语】以下是®文档大全网的小编为您整理的《excel2003汇总工作簿中多个工作表的统一指定行列内容到另一工作簿的汇总表下行填充》，欢迎阅读！
汇总工作簿中多个工作表的统一指定行列内容到另一工作簿的汇总表下行填充：
步骤：1.在原始数据同目录下新建一个工作簿，建立两个工作表，名称分别为“首页”和“合并汇总表”。
2.在“首页”中插入一个图型，右键指定到宏，新建，复制下列代码进去。点保存，点击“首页”工作表中插入的按钮，根据提示，浏览到原始数据工作簿。
3.下一步，用鼠标选择要合并的数据范围。
Dim wsNewWorksheet As Worksheet
Dim cel As Range
Dim DataSource, RowTitle, ColumnTitle, SourceDataRows, SourceDataColumns As Variant
Dim TitleRow, TitleColumn As Range
Dim Num As Integer
Dim DataRows As Long
DataRows = 1
Dim TitleArr()
Dim Choice
Dim MyName$, MyFileName$, ActiveSheetName$, AddressAll$, AddressRow$, AddressColumn$, FileDir$, DataSheet$, myDelimiter$
Dim n, i
n = 1
i = 1
Application.DisplayAlerts = False
Worksheets("合并汇总表").Delete
Set wsNewWorksheet = Worksheets.Add(, after:=Worksheets(Worksheets.Count))
wsNewWorksheet.Name = "合并汇总表"
MyFileName = Application.GetOpenFilename("Excel工作薄 (*.xls*),*.xls*")
If MyFileName = "False" Then
MsgBox "没有选择文件！请重新选择一个被合并文件！", vbInformation, "取消"
Else
Workbooks.Open Filename:=MyFileName
Num = ActiveWorkbook.Sheets.Count
MyName = ActiveWorkbook.Name
Set DataSource = Application.InputBox(prompt:="请选择要合并的数据区域：", Type:=8)
AddressAll = DataSource.Address
ActiveWorkbook.ActiveSheet.Range(AddressAll).Select
SourceDataRows = Selection.Rows.Count
SourceDataColumns = Selection.Columns.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To Num
ActiveWorkbook.Sheets(i).Activate
ActiveWorkbook.Sheets(i).Range(AddressAll).Select
Selection.Copy
ActiveSheetName = ActiveWorkbook.ActiveSheet.Name
Workbooks(ThisWorkbook.Name).Activate
ActiveWorkbook.Sheets("合并汇总表").Select
ActiveWorkbook.Sheets("合并汇总表").Range("A" & DataRows).Value = ActiveSheetName
ActiveWorkbook.Sheets("合并汇总表").Range(Cells(DataRows, 2), Cells(DataRows, 2)).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
DataRows = DataRows + SourceDataRows
Workbooks(MyName).Activate
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
Workbooks(MyName).Close
2023-04-09
