求助诊断多工作簿合并与工作簿拆分代码问题

Justin-2016 · 发表于 2018-8-19 15:04

本帖最后由 Justin-2016 于 2018-8-19 23:56 编辑

多工作簿合并.zip (48.13 KB, 下载次数: 7)

目前代码执行没有问题，但就是执行结果没有数据出来，求助大神帮忙诊断代码问题，谢谢！

lsc900707 · 发表于 2018-8-19 15:41

那么多的合并与拆分的代码，你非得自己整？

Justin-2016 · 发表于 2018-8-19 15:44

lsc900707 发表于 2018-8-19 15:41
那么多的合并与拆分的代码，你非得自己整？

请版主指点迷津，我目前没有其他能解决这个问题的方法，谢谢！

chxw68 · 发表于 2018-8-19 15:45

Justin-2016 发表于 2018-8-19 15:44
请版主指点迷津，我目前没有其他能解决这个问题的方法，谢谢！

看了下代码，其中问题比较多。

Justin-2016 · 发表于 2018-8-19 15:57

chxw68 发表于 2018-8-19 15:45
看了下代码，其中问题比较多。

可以的话，请大神帮忙优化，谢谢！

abc123281 · 发表于 2018-8-19 15:58

终于看到褚老师了

abc123281 · 发表于 2018-8-19 15:59

给你改写了汇总的代码
仅供参考

多工作簿合并123.rar (46.15 KB, 下载次数: 5)

lsc900707 · 发表于 2018-8-19 15:59

Justin-2016 发表于 2018-8-19 15:44
请版主指点迷津，我目前没有其他能解决这个问题的方法，谢谢！

多工作簿合并的：
Sub test()
Dim brr(1 To 100000, 1 To 7)
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xlsx")
Application.ScreenUpdating = False
Do While f <> ""
      If f <> ThisWorkbook.Name Then
         Set wb = Workbooks.Open(p & f)
         Arr = wb.Sheets(1).[A1].CurrentRegion
         wb.Close False
         For i = 2 To UBound(Arr)
            m = m + 1
            For j = 1 To 7
                  brr(m, j) = Arr(i, j)
            Next
         Next
      End If
      f = Dir
Loop
Set wb = Nothing
With Sheet1
      .Cells.ClearContents
      .[A1].Resize(1, 7) = Arr
      .[a2].Resize(m, 7) = brr
End With
Application.ScreenUpdating = True
MsgBox "合并完成！"
End Sub

abc123281 · 发表于 2018-8-19 16:07

你的汇总代码没有循环所以汇总没有数据
原因 strName = Dir(strPath & " *.xlsx") 中 * 符号前面是没有空格的当然还存在其它很多问题
自己测试了看

abc123281 · 发表于 2018-8-19 16:13

Set wb = CreateObject(strPath & strName)
Set wb = GetObject(strPath & strName)

		自动登录	找回密码
密码			免费注册

[已解决] 求助诊断多工作簿合并与工作簿拆分代码问题

评分

评分

评分

评分