多簿所有表格合并到一表
Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet
Application.ScreenUpdating = False
Set sh = ActiveSheet
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
[a1].CurrentRegion.Offset(2).Clear
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If sht.Name <> "总表" Then
If sht.[a65536].End(3).Row > 3 Then
lr = sh.[a65536].End(3).Row + 1
r = sht.[a65536].End(3).Row - 3
sh.Cells(lr, 1).Resize(r) = Split(MyName, ".")(0)
sh.Cells(lr, 2).Resize(r) = sht.Name
'sht.[a1].CurrentRegion.Offset(3, 7).Copy sh.Cells(lr, 3)
sht.Range("A4:G" & (r + 3)).Copy sh.Cells(lr, 3)
End If
End If
Next
.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
多簿所有表格合并到一簿
Sub 工作薄间工作表合并()
Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(.xlsx),.xlsx", MultiSelect:=True, Title:="合并工作薄")
X = 1
While X <= UBound(FileOpen)
Workbooks.Open Filename:=FileOpen(X)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
errhadler:
MsgBox Err.Description
End Sub
多簿同名表格合并到一表
Sub 指定表名提取成一工作薄() '字段必须要在第一列
On Error Resume Next
Dim Filename$, fn$, dq$, crr()
Set cnn = CreateObject("ADODB.Connection")
Dim arr, n&, i&, j&, s$
Dim MyPath$, myFile$
Dim rs As Object
Set d = CreateObject("scripting.dictionary")
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0';data source=" & ThisWorkbook.FullName
[a1:p65536].ClearContents
MyPath = ThisWorkbook.Path & "\"
myFile = Dir(MyPath & "*.xls*")
n = CreateObject("Scripting.FileSystemObject").GetFolder(MyPath).Files.Count - 1 '计算文件个数，减1不包括自身
ReDim arr(1 To 1000, 1 To n) '定义arr,最大工作表数1000
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then '不等于本工作簿执行
j = j + 1
i = 1
arr(1, j) = Left(myFile, InStrRev(myFile, ".") - 1) '去后辍
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath & myFile
Set rs = cnn.OpenSchema(20) 'Set rs = cnn.OpenSchema(adSchemaTables)，创建数据表记录集
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
i = i + 1
s = Replace(rs("TABLE_NAME").Value, "'", "") '去除"’"(数字工作表）
If Right(s, 1) = "$" Then arr(i, j) = Left(s, Len(s) - 1) '去除$号
End If
rs.MoveNext
Loop
End If
myFile = Dir
Loop
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Range("A1").Resize(i, j) = arr '输出
Rows("1:1").Delete
bmc = ActiveSheet.Name
brr = Worksheets(bmc).UsedRange
For Each cf In brr
If cf <> "" Then
d(cf) = ""
End If
Next
Worksheets(bmc).UsedRange.Delete
Application.ScreenUpdating = True
[b3].Resize(d.Count, 1) = Application.Transpose(d.keys)
[b2] = "所有的工作表名如下 请选择！"
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0';data source=" & ThisWorkbook.FullName
Flag: Set zzdm = Application.InputBox(prompt:="请在出现的表名称中选择 可以点选 或者全选：", Type:=8)
Application.ScreenUpdating = False
For Each Rng In zzdm '计算出所选单元格的个数
If Rng <> "" Then
a = a + 1
ReDim Preserve crr(1 To a)
crr(a) = Rng
End If
Next
ll = UBound(crr)
Columns(2).Delete
For Each c In crr
If c = "" Then GoTo 333
zdm = c
Filename = Dir(ThisWorkbook.Path & "\*.xls*")
Do While Filename <> ""
If Filename <> ThisWorkbook.Name Then
fn = ThisWorkbook.Path & "\" & Filename
Sql = "select * from [" & fn & "]." & "[" & zdm & "$" & "]"
r = [a65535].End(3).Row + 1
Cells(r, 1).CopyFromRecordset cnn.Execute(Sql)
r2 = [a65535].End(3).Row
yy = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
If r2 > 1 Then
If jj = 0 Then
Set rs = cnn.Execute(Sql)
For i = 0 To yy - 1 '逐个字段
Cells(1, i + 1) = rs.Fields(i).Name '取字段名
jj = jj + 1
Next i
End If
End If
End If
Filename = Dir
Loop
ActiveSheet.Name = zdm
ll1 = ll1 + 1
If ll1 < ll Then
ThisWorkbook.Sheets.Add After:=Worksheets(zdm)
End If
jj = 0
Next c
333:
cnn.Close: Set cnn = Nothing
Application.ScreenUpdating = True
MsgBox "提取完毕！"
End Sub
多簿指定工作表合并到一表
Sub mergeonexls() '合并多工作簿中指定工作表
On Error Resume Next
Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet
Dim t As Workbook, ts As Worksheet, l As Integer, h As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
Title:="Excel选择", MultiSelect:=True)
Set t = ThisWorkbook
Set ts = t.Sheets(1) '指定合并到的工作表，这里是第一张工作表
l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column
For Each x1 In x
If x1 <> False Then
Set w = Workbooks.Open(x1)
Set wsh = w.Sheets(1) '指定所需合并工作表，这里是第一张工作表
h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row
If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then
wsh.UsedRange.Copy ts.Cells(1, 1)
Else
wsh.UsedRange.Copy ts.Cells(h + 1, 1)
End If
w.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
同簿内多表合并到一表
Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
If Sheets(j).Name <> ActiveSheet.Name Then
X = Range("A65536").End(xlUp).Row + 1
Sheets(j).UsedRange.Copy Cells(X, 1)
End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
End Sub