多工作簿--区间复制黏贴合并到一个新表

ChenUser

求问大神们，

合并文件夹内所有文件中指定行的数据abc123.zip (13.88 KB, 下载次数: 8)

2018-9-12 17:18 上传

点击文件名下载附件
ss

我有个文件夹里面有好多个工作簿，但是都是一样的格式，附件举例了两个，我现在想新建个工作表，然后把文件夹里面的所有工作簿都合并到新建的工作表中，需要提取的数据为各个工作簿工作表里sheet1标黄部分。而且在新的工作表中需要在左边添加一列，列名各自行出自哪个工作簿名字的。
当然了，我的文件夹里面不止这两个工作簿，需要遍历一下。请高手们帮帮忙写个VBA代码。万分感谢。

比如新建的工作表需要得到的结果如下

lsc900707

多簿单表合并例子很多的，可以找来参考。

ChenUser

lsc900707 发表于 2018-9-12 17:44
多簿单表合并例子很多的，可以找来参考。

恩，但是我不会VBA，不知道怎么改，因为具体到一个区间的数据提取，而且多个工作簿合并，找了多份例子还是没弄出来，所以只能请教大神们了。

lsc900707

Sub test()
    Dim brr(1 To 100000, 1 To 10)
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.xls")
    Application.ScreenUpdating = False
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set sht = Workbooks.Open(p & f).Sheets(1)
            Arr = sht.[a1].CurrentRegion
            Workbooks(f).Close False
            For i = 2 To UBound(Arr) - 1
                m = m + 1
                brr(m, 1) = Split(f, ".")(0)
                For j = 2 To 10
                    brr(m, j) = Arr(i, j - 1)
                Next
            Next
        End If
        f = Dir
    Loop
    Set sht = Nothing
    With Sheet1
         .Cells.ClearContents
         [a1] = "来源": .[b1].Resize(1, UBound(Arr, 2)) = Arr
         .[a2].Resize(m, UBound(brr, 2)) = brr
    End With
    Application.ScreenUpdating = True
    MsgBox "合并完成！"
End Sub

lsc900707

请测试附件效果：

ChenUser

lsc900707 发表于 2018-9-12 17:56
请测试附件效果：

谢谢大神，麻烦了。

ChenUser

lsc900707 发表于 2018-9-12 17:56
请测试附件效果：

大神我碰到新的问题是，这个表其中又一列是文本的，所以这样代码弄出来，比如是0111111，这样弄过去变成111111前面的零不见了，能设置成复制黏贴的形式吗

lsc900707

ChenUser 发表于 2018-9-13 13:35
大神我碰到新的问题是，这个表其中又一列是文本的，所以这样代码弄出来，比如是0111111，这样弄过去变成1 ...

你把这一列设置成文本格式就好了。

ChenUser

lsc900707 发表于 2018-9-13 15:34
你把这一列设置成文本格式就好了。

谢谢，学到了、