如何把多个excel表合并到一个工作簿的各个sheet里面
2018-01-01 · 知道合伙人软件行家
关注
展开全部
昨天为银行朋友做了一个子行数据复制黏贴到汇总表。代码如下;
Public maxHH As Long
Sub main()
Dim zz As Integer
Dim bj As Boolean
Dim wjmArr(1 To 100) As String
Dim ksHh As Integer
Dim 检测列 As Integer
Dim hzBook As Workbook, zhBook As Workbook
Dim jsHH As Integer
Dim 子表名称 As String
Dim WIND1 As String, WIND2 As String
Dim hhZD
Application.DisplayAlerts = False
ksHh = Cells(3, 2).Value: maxHH = Cells(3, 4).Value
检测列 = Cells(3, 3).Value
Set hhZD = CreateObject("SCRIPTING.DICTIONARY")
Call 读取文件名(wjmArr, bj, zz)
Set hzBook = Workbooks.Open(ThisWorkbook.Path & "\" & wjmArr(1))
WIND1 = hzBook.Name
'清空汇总表
For Each mys In hzBook.Sheets
Range(mys.Cells(ksHh, 1), mys.Cells(maxHH, 100)).Clear
hhZD.Add mys.Name, ksHh
Next mys
'复制支行子表到总表
For i = 2 To zz
Set zhBook = Workbooks.Open(ThisWorkbook.Path & "\" & wjmArr(i))
WIND2 = zhBook.Name
For Each mys In zhBook.Sheets
jsHH = ksHh
Do While mys.Cells(jsHH, 检测列) <> ""
jsHH = jsHH + 1
Loop
If jsHH > ksHh Then
子表名称 = mys.Name
Range(mys.Cells(ksHh, 1), mys.Cells(jsHH - 1, 100)).Copy
Windows(WIND1).Activate
Sheets(子表名称).Activate
ActiveSheet.Cells(hhZD(子表名称), 1).Select
ActiveSheet.Paste
hhZD(子表名称) = hhZD(子表名称) + jsHH - ksHh
End If
Next mys
zhBook.Close
Next i
Application.DisplayAlerts = True
End Sub
Sub 读取文件名(ByRef wjmArr, ByRef bj, ByRef zz)
Dim FILENAME As String
Dim mypath As String
mypath = ThisWorkbook.Path
zz = 1
myfile = Dir(mypath & "\" & "*.xls*")
bj = False
Do While myfile <> ""
If myfile = "" Then
Exit Do '当MyFile为空的时候就说明已经遍历完了,这时退出Do,否则还要运行一遍
End If
If InStr(myfile, "工具") = 0 Then
If InStr(myfile, "汇总") > 0 Then
wjmArr(1) = myfile
bj = True
Else
zz = zz + 1
wjmArr(zz) = myfile
End If
End If
myfile = Dir '第二次读入的时候不用写参数
Loop
End Sub
Public maxHH As Long
Sub main()
Dim zz As Integer
Dim bj As Boolean
Dim wjmArr(1 To 100) As String
Dim ksHh As Integer
Dim 检测列 As Integer
Dim hzBook As Workbook, zhBook As Workbook
Dim jsHH As Integer
Dim 子表名称 As String
Dim WIND1 As String, WIND2 As String
Dim hhZD
Application.DisplayAlerts = False
ksHh = Cells(3, 2).Value: maxHH = Cells(3, 4).Value
检测列 = Cells(3, 3).Value
Set hhZD = CreateObject("SCRIPTING.DICTIONARY")
Call 读取文件名(wjmArr, bj, zz)
Set hzBook = Workbooks.Open(ThisWorkbook.Path & "\" & wjmArr(1))
WIND1 = hzBook.Name
'清空汇总表
For Each mys In hzBook.Sheets
Range(mys.Cells(ksHh, 1), mys.Cells(maxHH, 100)).Clear
hhZD.Add mys.Name, ksHh
Next mys
'复制支行子表到总表
For i = 2 To zz
Set zhBook = Workbooks.Open(ThisWorkbook.Path & "\" & wjmArr(i))
WIND2 = zhBook.Name
For Each mys In zhBook.Sheets
jsHH = ksHh
Do While mys.Cells(jsHH, 检测列) <> ""
jsHH = jsHH + 1
Loop
If jsHH > ksHh Then
子表名称 = mys.Name
Range(mys.Cells(ksHh, 1), mys.Cells(jsHH - 1, 100)).Copy
Windows(WIND1).Activate
Sheets(子表名称).Activate
ActiveSheet.Cells(hhZD(子表名称), 1).Select
ActiveSheet.Paste
hhZD(子表名称) = hhZD(子表名称) + jsHH - ksHh
End If
Next mys
zhBook.Close
Next i
Application.DisplayAlerts = True
End Sub
Sub 读取文件名(ByRef wjmArr, ByRef bj, ByRef zz)
Dim FILENAME As String
Dim mypath As String
mypath = ThisWorkbook.Path
zz = 1
myfile = Dir(mypath & "\" & "*.xls*")
bj = False
Do While myfile <> ""
If myfile = "" Then
Exit Do '当MyFile为空的时候就说明已经遍历完了,这时退出Do,否则还要运行一遍
End If
If InStr(myfile, "工具") = 0 Then
If InStr(myfile, "汇总") > 0 Then
wjmArr(1) = myfile
bj = True
Else
zz = zz + 1
wjmArr(zz) = myfile
End If
End If
myfile = Dir '第二次读入的时候不用写参数
Loop
End Sub
本回答被提问者采纳
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
百事牛
2024-10-28 广告
2024-10-28 广告
要取消Excel表格的密码,如果您知道密码,最直接的方式是在打开文件后,点击“文件”>“信息”,然后找到“保护工作簿”下的“用密码进行加密”。在弹出的对话框中,删除已设置的密码,点击“确定”并保存更改即可。若忘记密码,您可能需要考虑使用专业...
点击进入详情页
本回答由百事牛提供
2017-12-15
展开全部
如果数量不超过十个,还是复制粘贴来的快
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
展开全部
编程可以不要手工复制粘贴,几秒-几分钟出来 结果
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
展开全部
复制过来就可以
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询