Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2300|回复: 4

[已解决]求教高手:多个工作簿中内容合并到一张表上(急)

[复制链接]
发表于 2015-5-27 16:16 | 显示全部楼层 |阅读模式
本帖最后由 xuyongyanxyy 于 2015-5-28 09:47 编辑

有几百个类似附件中的Excel文件,名称不一样,但都是需要名为Data_1工作表中的F列,G列,及K列的信息, 需要合并到一张表上。求教高手相应的VBA代码。

万分感谢

最佳答案
2015-5-27 16:58
本帖最后由 爱疯 于 2015-5-27 16:59 编辑

Sub Click()
    Dim p, f, A, B(1 To 60000, 1 To 4), s, i
    p = ThisWorkbook.Path
    f = Dir(p & "\file\")
    Do While f <> ""
        With Workbooks.Open(p & "\file\" & f)
            A = Sheets(5).UsedRange
            For i = 2 To UBound(A)
                s = s + 1
                B(s, 1) = A(i, 6)
                B(s, 2) = A(i, 7)
                B(s, 3) = A(i, 11)
                B(s, 4) = f
            Next i
            .Close 0
        End With
        f = Dir
    Loop

    Workbooks.Add
    [a1].Resize(s, 4) = B
    ActiveWorkbook.SaveAs p & Format(Now, "yyyymmhh-hhmmss")
    ActiveWorkbook.Close
End Sub
1.rar (240.95 KB, 下载次数: 20)

Desktop.rar

223.9 KB, 下载次数: 17

例子

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2015-5-27 16:58 | 显示全部楼层    本楼为最佳答案   
本帖最后由 爱疯 于 2015-5-27 16:59 编辑

Sub Click()
    Dim p, f, A, B(1 To 60000, 1 To 4), s, i
    p = ThisWorkbook.Path
    f = Dir(p & "\file\")
    Do While f <> ""
        With Workbooks.Open(p & "\file\" & f)
            A = Sheets(5).UsedRange
            For i = 2 To UBound(A)
                s = s + 1
                B(s, 1) = A(i, 6)
                B(s, 2) = A(i, 7)
                B(s, 3) = A(i, 11)
                B(s, 4) = f
            Next i
            .Close 0
        End With
        f = Dir
    Loop

    Workbooks.Add
    [a1].Resize(s, 4) = B
    ActiveWorkbook.SaveAs p & Format(Now, "yyyymmhh-hhmmss")
    ActiveWorkbook.Close
End Sub
1.rar (240.95 KB, 下载次数: 20)

评分

参与人数 1 +1 收起 理由
xuyongyanxyy + 1 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-5-28 09:39 | 显示全部楼层
爱疯 发表于 2015-5-27 16:58
Sub Click()
    Dim p, f, A, B(1 To 60000, 1 To 4), s, i
    p = ThisWorkbook.Path

非常感谢您这么快速的回复。我试了,很成功。 就是不知怎么结果文件自动存在的地方是1.xlsm的上层文件夹。 但不是大问题。
非常感谢!
回复

使用道具 举报

发表于 2015-5-28 09:57 | 显示全部楼层
Sub Click()
    Dim p, f, A, B(1 To 60000, 1 To 4), s, i
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "file\")
    Do While f <> ""
        With Workbooks.Open(p & "file\" & f)
            A = Sheets(5).UsedRange
            For i = 2 To UBound(A)
                s = s + 1
                B(s, 1) = A(i, 6)
                B(s, 2) = A(i, 7)
                B(s, 3) = A(i, 11)
                B(s, 4) = f
            Next i
            .Close 0
        End With
        f = Dir
    Loop

    Workbooks.Add
    [a1].Resize(s, 4) = B
    ActiveWorkbook.SaveAs p & Format(Now, "yyyymmhh-hhmmss")
    ActiveWorkbook.Close
End Sub
2.rar (240.9 KB, 下载次数: 9)
回复

使用道具 举报

 楼主| 发表于 2015-5-29 16:18 | 显示全部楼层
爱疯 发表于 2015-5-28 09:57
Sub Click()
    Dim p, f, A, B(1 To 60000, 1 To 4), s, i
    p = ThisWorkbook.Path & "\"

试了。很好用。非常感谢!
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 20:15 , Processed in 1.166372 second(s), 18 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表