合并代码求修改

LWXT

各位高手我在网上求得一合并文件夹下所有工作簿中第一个工作表的代码，非常好用。该代码合并后保留原工作表的公式、格式等，但是日常工作中有些表格保留公式，合并后出现错误。我是初学，求高手帮助修改下代码，使得合并后的工作表不包含原工作表的公式、格式。谢谢
代码如下： 详见附件 事例.zip (138.3 KB, 下载次数: 4)

2017-8-11 23:43 上传

点击文件名下载附件

Sub合并()

  Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer

  Application.ScreenUpdating = False       '冻结屏幕，以防屏幕抖动

  myPath = ThisWorkbook.Path & "\"          '把文件路径定义给变量

  myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件

   DoWhile myFile <> ""                     '当指定路径中有文件时进行循环

     If myFile <> ThisWorkbook.Name Then

        Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件

         For i = 1 To AK.Sheets.Count

        aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row

        tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row +1

           'AK.Sheets(i).Select

        AK.Sheets(i).Range("a2:k" & aRow).CopyThisWorkbook.Sheets(1).Range("a" & tRow)

        Next

        Workbooks(myFile).Close False               '关闭源工作簿,并不作修改

     End If

     myFile = Dir                                   '找寻下一个*.xls文件

  Loop

  Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用

  MsgBox "汇总完成，请查看！", 64, "提示"

End Sub

weiqigreen

修改， AK.Sheets(i).Range("a2:k" & aRow).CopyThisWorkbook.Sheets(1).Range("a" & tRow)
不用copy命令，用数组取单元格的值。

需要具体问题具体分析，没有附件就不便于研究学习了。

供参考。

lsc900707

有公式的合并最好用数组法改写。但是最好上传附件。

LWXT

weiqigreen 发表于 2017-8-11 22:35
修改， AK.Sheets(i).Range("a2:k" & aRow).CopyThisWorkbook.Sheets(1).Range("a" & tRow)
不用copy命令 ...

非常感谢您的解答，我已上传了附件，麻烦您帮忙修改下，谢谢

LWXT

lsc900707 发表于 2017-8-11 23:12
有公式的合并最好用数组法改写。但是最好上传附件。

非常感谢，已重新上传了附件，麻烦您修改下。谢谢

weiqigreen

LWXT 发表于 2017-8-11 23:26
非常感谢您的解答，我已上传了附件，麻烦您帮忙修改下，谢谢

1. 'AK.Sheets(1).Range("A4:BL" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow)   'A3指开始合并单元格位置，可据实修改，BL指列的宽度（64列），日常基本够用不用修改。
   
2.          'weiqigreen:将上一句换成下面两句：
   
3.          brr = AK.Sheets(1).Range("A4:E" & aRow)
   
4.          ThisWorkbook.Sheets(1).Cells(tRow, 1).Resize(UBound(brr), UBound(brr, 2)) = brr

复制代码

修改后的_事例2.rar (125.71 KB, 下载次数: 10)

2017-8-12 00:21 上传

点击文件名下载附件

lsc900707

LWXT 发表于 2017-8-11 23:44
非常感谢，已重新上传了附件，麻烦您修改下。谢谢

Sub 按钮1_单击()
   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer, arr()
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   myPath = ThisWorkbook.Path & "\分表\"          '把文件路径定义给变量
   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
   Do While myFile <> ""                     '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件
          For i = 1 To AK.Sheets.Count
              With AK.Sheets(i)
                 aRow = .Range("a65536").End(xlUp).Row
                 arr = .Range("a2:i" & aRow).Value
                 tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1
                 ThisWorkbook.Sheets(1).Range("a" & tRow).Resize(UBound(arr), UBound(arr, 2)) = arr
               End With
         Next
         Workbooks(myFile).Close False               '关闭源工作簿,并不作修改
      End If
      myFile = Dir                                   '找寻下一个*.xls文件
   Loop
   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
   MsgBox "汇总完成，请查看！", 64, "提示"
End Sub

LWXT

weiqigreen 发表于 2017-8-12 00:21

非常感谢您的帮助，经测试完全复合要求，但我认为： brr = AK.Sheets(1).Range("A4:E" & aRow) 中的A4：E 还是修改成 A4；BL 比较合适些，A4代表表头行数为3行从A4开始复制，BL代表汇总工作表的宽度，BL代表工作表有64列，一般工作表都超不过64列，这样汇总工作表就能当工具表使用了，任意工作表汇总只需根据实际修改表头行数（A4）一个参数即可（列宽64列基本不用修改）。这样通用性强一点，基本上任意工作表汇总只需根据表头行数修改一个参数即可（列宽基本都在BL即64列之内）。再次感谢您的帮助。

LWXT

lsc900707 发表于 2017-8-12 01:09
Sub 按钮1_单击()
   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer, arr()
   A ...

非常感谢帮助，经测试完全复合要求，我稍作修改， a2:i  修改成 a2:bl （或者zz） 理由同 回复weiqigreen
示例附件表头1行表格列宽9列（i列）完全复合要求。把工作表列宽 i 设置成一般表格都不会超过的列宽，如BL(64列），这样汇总工作簿汇总任意工作表，只修根据工作表表头行数修改一个参数即可。通用性强，可做工具表使用。
再有今天的评分用完了，明天补上，再次感谢。

lsc900707

LWXT 发表于 2017-8-12 14:48
非常感谢帮助，经测试完全复合要求，我稍作修改， a2:i  修改成 a2:bl （或者zz） 理由同 回复weiqigreen ...

根据自己的实际需求稍作修改即可。关键在于我们要学会举一反三。