[已解决]VBA如何批量复制多个工作薄中某特定工作表内的特定内容到一个新的工作薄

amy99

各位大侠，求助！！！
我的问题是这样的，我需要将多个工作薄中的特定工作表内地特定内容复制到一个新的工作薄中，所复制过来的内容依次排列在一起。举例说明如下，我需要将附件中“源文件”夹内的几个省份的工作薄内的“附件6”中，对应于合并单元格“专业1”所对应的行的所有内容都复制到“汇总表”工作薄内。这是我希望实现的主要内容。
另外，如果能够顺带实现以下内容则更好了：在复制汇总的同时，还能将“专业1”合并单元格去除，并用所复制的源文件的文件名中的省份名来代替，比如从“附件1：北京分公司总册附表”复制过来的那些行，“专业1”的合并单元格去除后用“北京”来代替，用于标注这些行是属于哪个省份的，因为这些行里面的内容有可能不包含省份的信息，复制在一起后很容易造成混乱。

我每天的工作内容都需要反复的做这类的汇总工作，量大的时候非常繁琐。所以非常急切的需要vba的自动解决方案，在此先谢过了！万分感谢！！！

最佳答案

月排行榜 / 总排行榜

lichuanboy44

2016-1-6 23:17

amy99 发表于 2016-1-6 17:27
非常感谢楼上lichuanboy44！不好意思，回复晚了，因为竟然忘了密码且邮箱进不去重置。。。
我刚开始接触 ...

      只汇总每个附件1工作簿的“附表6”中“专业1”所在的数据行的问题，已解决
      关于打开工作簿出现错误提示的问题，暂不知原因。我是将你的所有附件1工作簿复制处理后，本程序才正常运行
      还有一个提示，就是如果附件1的“附表6”A列没有“专业1“时，match函数会出错，导到程序中途停止运行。如果你想忽略此错误，可在程序语句的开头处，加一句 on error resume next  即出现错误，继续执行的意思

跳转到最佳答案楼层

lichuanboy44

先给你一个调试成功的示例，但你提供的附表有个问题：正常打开时提示“发现不可读取的内容…………”，估计是其它程序导出的excel格式表。我将你的表重新复制转换后程序才正常运行，这是多个外簿数据汇总的通用作法。
代码如下：

Sub 汇总()
Dim arr数据
    Dim s行 As Integer
    Set wk汇总 = Worksheets("附表6")
    yesno = MsgBox("本操作将与本工作簿同文件夹的excel明细数据自动复制到本工作簿中" & _
                   vbCrLf & " 如果未准备好，请点击“否”退出程序", vbYesNo + vbDefaultButton2)
    If yesno = vbNo Then
        Exit Sub
    End If
    wkcount = 0
    With wk汇总.Range("A2:F5000")
      .UnMerge
      .ClearContents
    End With
    '******************************************
    Filename = Dir(ThisWorkbook.Path & "\*.xls")
    Do While Filename <> ""
        If Filename <> ThisWorkbook.Name Then
            sr = VBA.Mid(Filename, 5, 2)
            fn = ThisWorkbook.Path & "\" & Filename
            Set wb = Workbooks.Open(fn)
            Set Sht = wb.Worksheets(1)
            j = Sht.Range("C65536").End(xlUp).Row
            arr数据 = wb.Worksheets(1).Range("B2:F" & j)
            wb.Close False
            s行 = wk汇总.Range("C65536").End(xlUp).Row
            wk汇总.Range("B" & s行 + 1).Resize(j - 1, 5) = arr数据
            wk汇总.Range("A" & s行 + 1).Resize(j - 1, 1) = sr
            wkcount = wkcount + 1
        End If
        Filename = Dir
    Loop
    '***************************
    If wkcount = 0 Then
        MsgBox "指定文件夹内没有明细报表"
        'Exit Sub                                        '如果指定文件夹下没有报表，则退出
    End If
End Sub

amy99

非常感谢楼上lichuanboy44！不好意思，回复晚了，因为竟然忘了密码且邮箱进不去重置。。。
我刚开始接触VBA，可谓一窍不通，所以看代码只能大概明白一点点，说得不对的让大家见笑了。

刚开始我是把上面的代码拷贝到我的“汇总”工作薄里进行运行的，运行几次结果都不对。后来完整的下载了楼上的整个压缩包才运行正确了。
这里还想请教楼上，是什么原因造成运行结果不对呢？是因为打开文件出现错误吗？好像贵州省有一个“附件1”的sheet我忘了删除，感觉运行后复制过来的东西似乎都是贵州”附件1“的内容。

另外，我的excel打开很多文件经常都有提示“不可读取内容”，所以有一些VBA程序在我这里都没法正常运行，但在别人的机器上同样的文件却又能很正常的运行出正确的结果。不知是什么原因，你们有遇到过类似的情况吗？是我的excel有问题吗？

----------------------------------------------------------------
下面再说说我的需求，之前可能没有说得很清楚。
我希望可以把同一个文件夹内的多个工作薄（在此对应于不同省份）的特定工作表（在此对应于”附表6“）的特定内容（在此对应于合并单元格“专业1”所对应的行）复制到新的工作薄（在此对应于“汇总表”）里进行汇总。
也即是说需要进行复制的每个工作薄文件里会有很多sheet（我那里面把其它的sheet都删了，实际上会有很多非空的sheet），但只需要复制“附表6”sheet，而且只复制“附表6”sheet里的部分内容（在此是对应于“专业1”所在的行），“附表6”sheet的其它部分的内容不用复制。
另外，还需注意的是，每个省份的“附表6”名字是固定的，“专业1”名字也是固定的，但“专业1”在sheet里的起始位置是不确定的，行数也是不确定的，有的多有的少，即“专业1”之前可能有其他不需要复制的内容，“专业1”之后也有其他不需要复制的内容。

所以，是否能够再麻烦一下楼上大拿，帮忙修改一下代码，以满足复制特定内容的需求。
之前的代码似乎是把每个工作薄的sheet”附件6“中的内容全部都复制过去了。
另外，能否辛苦多写一点注释，很汗颜的说因为我尚未入门。。。
不胜感激～～～～～～～

lichuanboy44

amy99 发表于 2016-1-6 17:27
非常感谢楼上lichuanboy44！不好意思，回复晚了，因为竟然忘了密码且邮箱进不去重置。。。
我刚开始接触 ...

      只汇总每个附件1工作簿的“附表6”中“专业1”所在的数据行的问题，已解决
      关于打开工作簿出现错误提示的问题，暂不知原因。我是将你的所有附件1工作簿复制处理后，本程序才正常运行
      还有一个提示，就是如果附件1的“附表6”A列没有“专业1“时，match函数会出错，导到程序中途停止运行。如果你想忽略此错误，可在程序语句的开头处，加一句 on error resume next  即出现错误，继续执行的意思

amy99

测试了下，超级好用哦，尤其那句 on error resume next ，楞是帮我把20多个文档运行完了。。。
谢谢lichuanboy44了，太感谢了！解决我的大问题了！没想到我成天复制粘贴复制粘弄得眼都快瞎了，你几行代码就可以帮我搞定了，太强了！膜拜啊！
收藏了慢慢学习，辛苦了这么快回复！加上注释后我基本能看懂了，但不知何时才能也像你们一样能写出个像样点代码来呢，感觉好难的样子
大拿们，有什么好书、好材料、好方法推荐吗？

登科001

大赞，受教了

amy99

lichuanboy44 发表于 2016-1-6 23:17
只汇总每个附件1工作簿的“附表6”中“专业1”所在的数据行的问题，已解决
      关于打开工作簿 ...

高手您好，我现在有一些新的需求，想您再次帮忙指点一下。
首先是数组转置的问题。
您上次用了一个临时内存数组arr数据存放需要copy的数据，请问如何将这些数据转置呢？
我网上搜看到说用Application.Transpose.arr数据，但老是报错说“无效的数字或参数”，是什么问题呢？该如何调试呢？

还有一些其他的问题，我明天有空再请教。非常感谢！

lichuanboy44

amy99 发表于 2016-5-18 18:05
高手您好，我现在有一些新的需求，想您再次帮忙指点一下。
首先是数组转置的问题。
您上次用了一个临时 ...

转置用Application.Transpose没错，但相应的行列参数也要互换，否则报错。
原语句： wk汇总.Range("B" & s行 + 1).Resize(j - 1, 5) = arr数据
转   置： wk汇总.Range("B" & s行 + 1).Resize(5, j - 1) = Application.Transpose(arr数据)
请注意：上面的j-1转置后变到列，5变为行。

amy99

lichuanboy44 发表于 2016-5-18 18:53
转置用Application.Transpose没错，但相应的行列参数也要互换，否则报错。
原语句： wk汇总.Range("B" & ...

原来我是犯了最低级的错误，直接用Application.Transpose.arr数据，这样是否就误把arr数据当成Range对象了？用你的语句给arr数据加上括号就对了。行列参数互换的确也必须注意，谢谢高手提醒，尽管我那里只有一列要转置成一行所以我是无意中蒙对了。令我抓狂老半天的一小段代码终于能正确运行出结果了，这种感觉还是很爽的哈。感谢感谢！
后续更多问题请高手继续赐教啊～～～～

amy99

lichuanboy44 发表于 2016-5-18 18:53
转置用Application.Transpose没错，但相应的行列参数也要互换，否则报错。
原语句： wk汇总.Range("B" & ...

高手，继续请教，如何对数组进行分列求和呢，即需要对“arr数据”的每一列分别进行求和？先谢了！