同一文件夹下，多层子文件夹工作簿汇总在总表里面

sulli112 · 发表于 2020-10-1 17:51

问题图上传

MyLaLaLand · 发表于 2020-10-2 09:11

本帖最后由 MyLaLaLand 于 2020-10-2 09:33 编辑

改成 If sh.Name = "Sheet1" Then ？改这句就能抓所有sheet1 不管被抓的表名 With wb0.Sheets(Sheet1.Name) 改这句就能把所有内容抓到宏的sheet1 中不管处理宏表名，不知道你的sheet0是哪来的给我的附件也不是有问题的附件实在无法理解怎么进的 If sh.Name = "Sheet0" Then 这个判断

sulli112 · 发表于 2020-10-2 11:54

MyLaLaLand 发表于 2020-10-2 09:11
改成 If sh.Name = "Sheet1" Then ？改这句就能抓所有sheet1 不管被抓的表名 With wb0.Sheets(Sheet1.Name ...

我按照你这个去进行修改，可以运行，但是显示空白，没有把数据带到汇总表里面

MyLaLaLand · 发表于 2020-10-2 13:15

sulli112 发表于 2020-10-2 11:54
我按照你这个去进行修改，可以运行，但是显示空白，没有把数据带到汇总表里面

你发你有问题的附件给我吧你现在这个附件是原始的也啥都抓不上来

sulli112 · 发表于 2020-10-2 14:07

MyLaLaLand 发表于 2020-10-2 13:15
你发你有问题的附件给我吧你现在这个附件是原始的也啥都抓不上来

新附件已上传，您看看能不能只合并有数据那几行，谢谢

MyLaLaLand · 发表于 2020-10-2 15:26

MyLaLaLand 发表于 2020-10-2 13:15
你发你有问题的附件给我吧你现在这个附件是原始的也啥都抓不上来

我的问题是改成If sh.Name = "Sheet1" 是行不通的，犯傻了既然已经确定固定抓取每个表的sheet1内容那么直接用wb.Worksheets(1)就可以了。你的问题是.Cells(2, DataRows).PasteSpecial Paste:=xlPasteValues 黄色那行行列写反了。。。应该是.Cells(DataRows, 2).PasteSpecial Paste:=xlPasteValues ...用黄色字体真的很难看出来。。。然后唯一的问题就是没有数据的也被抓取了那个应该是那些原始文件格式的问题，找最大行总是找到1001，用现在这段直接复制粘贴会把抓取表也变为这种格式因此我改了一段，用数组转移数据就好啦，也就是一共不止一个问题太难找了....现在发现接手别人的代码还不如自己重新写一个实际上我自己写的也马上写好了就把这两者结合一下发过去吧 10格式的我直接粘代码得了...

MyLaLaLand · 发表于 2020-10-2 15:30

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim DataRows&
Dim arr
With CreateObject("Wscript.Shell")
      ListFileArr = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & ThisWorkbook.Path & Chr(34)).StdOut.ReadAll, vbCrLf)
      ListFileArr = filter(ListFileArr, ".xl")
End With

Set wb0 = ThisWorkbook
DataRows = Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row
If DataRows >= 2 Then Sheet1.Rows("2:" & DataRows).ClearContents
For i = 0 To UBound(ListFileArr)
      DataRows = Val(Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row) + 1
      mypath = ListFileArr(i)
      TmpName = Split(mypath, "\")(UBound(Split(mypath, "\")))
      If mypath <> ThisWorkbook.FullName And InStr(mypath, ".xlsm") = 0 Then
         Set wb = Workbooks.Open(mypath)
         Set sh = wb.Worksheets(1)
         LastRow = sh.Cells(sh.Cells.Rows.Count, 1).End(xlUp).Row
         arr = sh.Range("B2:F" & LastRow).Value
         wb.Close
         Sheet1.Cells(DataRows, 2).Resize(UBound(arr), UBound(arr, 2)).Value = arr
         DataRowsE = Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row
         Sheet1.Range("G" & DataRows & ":" & "G" & DataRowsE).Value = TmpName
      End If
Next i

MsgBox "数据汇总完毕！"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

sulli112 · 发表于 2020-10-2 16:25

MyLaLaLand 发表于 2020-10-2 15:30
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayA ...

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim DataRows&
Dim arr
With CreateObject("Wscript.Shell")
      ListFileArr = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & ThisWorkbook.Path & Chr(34)).StdOut.ReadAll, vbCrLf)
   ListFileArr = filter(ListFileArr, ".xl")这句话是不是指抓取数据工作簿格式XLS,XLSX都可以呢
End With

Set wb0 = ThisWorkbook
   DataRows = Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row
If DataRows >= 2 Then Sheet1.Rows("2:" & DataRows).ClearContents
For i = 0 To UBound(ListFileArr)
      DataRows = Val(Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row) + 1
      mypath = ListFileArr(i)
      TmpName = Split(mypath, "\")(UBound(Split(mypath, "\")))
      If mypath <> ThisWorkbook.FullName And InStr(mypath, ".xlsm") = 0 Then
         Set wb = Workbooks.Open(mypath)
          Set sh = wb.Worksheets(1)，如果要改为第二个工作表抓取数据，这里改为WORKSHEETS(2)
         LastRow = sh.Cells(sh.Cells.Rows.Count, 1).End(xlUp).Row
         arr = sh.Range("B2:F" & LastRow).Value
         wb.Close
        Sheet1.Cells(DataRows, 2).Resize(UBound(arr), UBound(arr, 2)).Value = arr
      DataRowsE = Sheet1.Cells(Sheet1.Cells.Rows.Count, 2).End(xlUp).Row
         Sheet1.Range("G" & DataRows & ":" & "G" & DataRowsE).Value = TmpName
      End If
Next i

MsgBox "数据汇总完毕！"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
有几处颜色一致的，如果改为抓取第二个工作表的数据，就要将sheet1改为sheet2对吗，谢谢

opiona · 发表于 2020-10-2 20:04

sulli112 发表于 2020-10-1 17:51
我下载了第7个不同标题合并，但是老是显示少了一个参数，有问题的地方我已经截图放在下一楼

5_多工作簿指定工作表，全部数据汇总.rar (65.99 KB, 下载次数: 44)

sulli112 · 发表于 2020-10-2 21:33

opiona 发表于 2020-10-2 20:04

可以了，谢谢

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

[求助] 同一文件夹下，多层子文件夹工作簿汇总在总表里面

评分

评分

评分