excel多表合一解决办法(2种办法)

在要合并的工作薄文件中的第一张表前先新建一张表,名称自定,可为汇总表,
点工具菜单中的宏之下的VB编辑器，然后点中间的运行宏按钮，
输入一个宏名称，点右边的创建按钮，
然后将在代码框中输入以下语句，关闭代码框，运行宏即可。

Sub 汇总()
Sheets("汇总表").Select '假设存放汇总结果的工作表名称叫汇总表，如果不是请做相应修改
For Each s In ThisWorkbook.Worksheets
With s
If .Name <> "汇总表" Then '表名修改同上
.UsedRange.Offset(1, 0).Copy [A65536].End(xlUp).Offset(1, 0)
End If
End With
Next
End Sub

在未新建表情况下,在要合并的工作薄文件中的第一张表中，点工具菜单中的宏之下的VB编辑器，
然后点中间的运行宏按钮，输入一个宏名称，点右边的创建按钮，
然后将在代码框中输入以下语句，关闭代码框，运行宏即可。
在要合并的工作薄文件中的第一张表中，点工具菜单下的宏下的VB编辑器，
然后点中间的运行宏按钮，输入一个宏名称，点右边的创建按钮，然后将第2句到到处第2句复制到代码框中，关闭代码框，运行宏即可。
Sub 汇总数据()
Sheets.Add
With ActiveSheet
.Name = "汇总表" & Format(Now, "hhmmss")
For Each s In ThisWorkbook.Sheets
https://www.360docs.net/doc/d11823739.html,edRange.Copy .Cells(.UsedRange.Rows.Count + 1, 1)
Next
End With
End Sub

以上为成功代码。



Sub 合并()
Dim i%
Sheets(1).UsedRange.Copy [a1]
For i = 1 To Sheets.Count
If Sheets(i).Name <> https://www.360docs.net/doc/d11823739.html, Then Sheets(i).UsedRange.Offset(2, 0).Copy [a65536].End(xlUp).Offset(1, 0)
Next i
End Sub




轻轻一点，工作簿自动合并。
轻轻一点，工作簿记录自动合并。代码在示例表中（在汇总表中点右键，查看代码）
1，本工作簿中各表的记录自动合并到总表
2，多工作簿记录合并到总表

关于在本工作簿汇总各表的记录到总表代码，根据有的用户要求，想有选择地从各表中某行或某列中复制记录到总表中，你可以将下面的代码复盖原来的代码。红色的字符是选择范围，蓝色字符（如：1）表示是插入到总表的第二行（第一行是列标题），这两处可自行修改。(2009.3.30)

Sub 工作簿汇总()
For Each st In Worksheets
If https://www.360docs.net/doc/d11823739.html, <> https://www.360docs.net/doc/d11823739.html, Then https://www.360docs.net/doc/d11823739.html,edRange.Range("a2:f31").Copy [a65536].End(xlUp).Offset(1, 0)
Next
End Sub





用个简单的公式就可以了=IF(Sheet1!A2="",Sheet2!A2,Sheet1!A2) ，这是A列的，公式含义就是加入表一A2单元格为空的话，那么就等于表2的，有内容的话就等于表1的，这样应该就可以实现合并了



Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer

On Error GoTo ErrHandler
Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="MicroSoft Excel文件(*.xls),*.xls", _
MultiSelect:=True, Title:="要合并的文件")


If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "没有选中文件"
GoTo ExitHandler
End If

x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
Sheets().Move after:=ThisWorkbook.Sheets _
(ThisWorkbook.Sheets.Count)
x = x + 1

Wend

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub







如何把EXCEL多个工作表的内容合并在一个工作表上
我想用宏 ，多个，，，200个，怎么复制？？
试验成功：在要合并的工作薄文件中的第一张表中，点工具菜单下的宏下的VB编辑器，
然后点中间的运行宏按钮，输入一个宏名称，点右边的创建按钮，然后将第2句到到处第2句复制到代码框中，关闭代码框，运行宏即可。
Sub 汇总数据()
Sheets.Add
With ActiveSheet
.Name = "汇总表" & Format(Now, "hhmmss")
For Each s In ThisWorkbook.Sheets
https://www.360docs.net/doc/d11823739.html,edRange.Copy .Cells(.UsedRange.Rows.Count + 1, 1)
Next
End With
End Sub

以上为成功代码。







Option Explicit
Option Compare Text '大小写一样，如A=a,B=b

Sub 合并EXCEL文件()
'2003\2007可用,2009-10-09修改zjxia889
'合并多个EXCEL工作簿的表名中包含特定关键字的工作表或全部工作表
ActiveWorkbook.Save '先保存目标文件
Dim FilesToOpen '缺省情况被声明为 Variant
Dim X As Integer
Dim I As Integer
Dim Mname As String
Dim Oname As String
Dim Keyn As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False

Mname = https://www.360docs.net/doc/d11823739.html, '目标文件名
FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.xls),*.xls", Title:="", MultiSelect:=True) '在此导入的EXCEL2007文件,扩展名在这里可自己指定

If TypeName(FilesToOpen) = "Boolean" Then 'Boolean 数据类型,只有两种值的数据类型，这两种值分别为 True(-1) 或 False(0)。 Boolean 变量是以 16 位 ( 2 字节 ) 数字存储的。
MsgBox "没有选中文件"
GoTo ExitHandler
End If

Keyn = InputBox("请输入需要合并的工作表名(包含关键字)" & _
Chr(10) & "后续所选文件的全部工作表导入,直接按确定或取消") ', , https://www.360docs.net/doc/d11823739.html,)

X = 1
While X <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(X)
With ActiveWorkbook
Oname = .name '源文件名
For I = 1 To .Sheets.Count
If InStr(Sheets(I).name, Keyn) Then '如果Keyn为空则全部复制

.Sheets(I).Copy After:=Workbooks(Mname).Sheets(Workbooks(Mname).Sheets.Count) '复制到目标文件的最后一张表
Workbooks(Mname).Sheets(Workbooks(Mname).Sheets.Count).name = Replace(Oname, ".xls", "-") & .Sheets(I).name '重命名
End If
Next I
.Close '源文件关闭
X = X + 1
End With
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub







SELECT *FROM `D:\桌面\123\1.xls`.`Sheet1$` `Sheet1$`
union all
SELECT *FROM `D:\桌面\123\2.xls`.`Sheet1$` `Sheet1$`
union all
SELECT *FROM `D:\桌面\123\3.xls`.`Sheet1$` `Sheet1$`






'***************************************************
'# By gvntw 王建发 #
'# 引用 Microsoft Scripting Runtime #
'# 引用 Microsoft ActiveX Data Objects 2.8 Library #
'# 引用 Microsoft ADO Ext.2.8 For DDL and Security #
'***************************************************
Private Sub CommandButton1_Click()
Dim d As New Dictionary, arr(), i%, j% '声明字典、数组、整型变量
Dim cn As New ADODB.Connection 'ADO对象
Dim rst As New ADODB.Recordset '记录集对象
Dim cat As New Catalog 'ADOX引用
Dim sql$, MyPath$, MyFiles$, TWb$ 'String 变量

On Error GoTo Err '发生错误跳到 Err
Cells = Empty '清空单元格数据
TWb = https://www.360docs.net/doc/d11823739.html, '取本工作簿名

MyPath = ThisWorkbook.Path '文件路径
MyFiles = Dir(MyPath & "*.xls") '取文件名
Do While MyFiles <> "" '循环文件
If TWb <> MyFiles Then '如果不是本工作簿文件名
d.Add MyFiles, 0 '把文件名添加到字典对象
j = j + 1 '文件数量计数
End If
MyFiles = Dir '下一个文件
Loop '进入下一个循环迭代

If j = 0 Then '如果文件数量为0，则弹出对话框
MsgBox "没有文件可合并", , "gvntw"
Exit Sub '退出过程
End If

arr = d.Keys: d.RemoveAll '把字典里的Keys赋值给数组，移除字典所有键值
For i = 0 To UBound(arr) '循环工作簿
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & "" & arr(i) '打开ADO联接
Set cat.ActiveConnection = cn '设置ADOX引用
For Each Tabs In cat.Tables '循环工作表
sql = "Select """ & Replace(arr(i), ".xls", "") & """ as 单位,""" & Replace(https://www.360docs.net/doc/d11823739.html,, "$", "") & _

""" as 月份,* From [Excel 8.0;DATABASE=" & MyPath & "" & arr(i) & "].[" & https://www.360docs.net/doc/d11823739.html, & "]" 'sql语句
d.Add sql, 0 '添加到字典
Next '下一个循环迭代
cn.Close '关闭联接
Next '下一循环
sql = Join(d.Keys, " UNION ALL ") '把字典的Keys用“ UNION ALL ”连接赋值给sql
sql = "SELECT * from (" & sql & ") where 姓名 like '王%' order by 姓名,月份"
'只汇总姓王的记录，如果要汇总全部记录，请把“where 姓名 like '王%'”删除，在sql语句中用%作用通配符，而不用*号
cn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties=Excel 8.0;Data Source=" & arr(0) '打开联接
Set rst = cn.Execute(sql) '记录集
For i = 1 To rst.Fields.Count '循环字段
Cells(1, i) = rst(i - 1).Name '录入字段名
Next '下一循环

Range("a2").CopyFromRecordset rst '复制查询结果
rst.Close: Set rst = Nothing '关闭记录集，并在内存中清除
cn.Close: Set cn = Nothing: Set d = Nothing '关闭ADO联接，并在内存中清除ADO和字典对象，释放内存
MsgBox "表格已汇总完成", , "gvntw" '弹出完成对话框
Exit Sub '退出过程
Err: '错误跳转程序
MsgBox Err.Description, , "错误报告" '弹出错误原因报告
End Sub '结束过程




如何把EXCEL多个工作表的内容合并在一个工作表上
我想用宏 ，多个，，，200个，怎么复制？？
试验成功：在要合并的工作薄文件中的第一张表中，点工具菜单下的宏下的VB编辑器，
然后点中间的运行宏按钮，输入一个宏名称，点右边的创建按钮，然后将第2句到到处第2句复制到代码框中，关闭代码框，运行宏即可。
Sub 汇总数据()
Sheets.Add
With ActiveSheet
.Name = "汇总表" & Format(Now, "hhmmss")
For Each s In ThisWorkbook.Sheets
https://www.360docs.net/doc/d11823739.html,edRange.Copy .Cells(.UsedRange.Rows.Count + 1, 1)
Next
End With
End Sub

以上为成功代码。