Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

工作中常用的Excel函数公式,全印在一张超大鼠标垫上
查看: 382|回复: 6

[已解决] 萌新求助,如何用vba统计同一文件夹指定表格所有内容?

[复制链接]
发表于 2019-10-12 18:52 | 显示全部楼层 |阅读模式
求大神普及,在同一文件夹内有相同格式的表格,想提取出统计栏工作表里第七行,汇总到一个表格,(另外还有第11行第17行的数据也需要汇总),如果能在第一列加上文件的名称就更完美了。 微信截图_20191012183124.png
纯萌新,教程的代码完全不知道该怎么弄,求大神赐教,自己试试举一反三。感谢,感谢

旅游项目内部表单1 .rar

165.63 KB, 下载次数: 6

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2019-10-12 19:40 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2019-10-13 13:17 | 显示全部楼层
回复

使用道具 举报

发表于 2019-10-14 15:10 | 显示全部楼层
星尘锁链 发表于 2019-10-13 13:17
没了,就这一个表啊

看不懂你的要求
回复

使用道具 举报

发表于 2019-10-18 14:57 | 显示全部楼层
在文件夹中新建一工作簿,加入代码即可。
2019-10-18表单.png
回复

使用道具 举报

 楼主| 发表于 2019-11-28 12:19 | 显示全部楼层
蓝桥玄霜 发表于 2019-10-18 14:57
在文件夹中新建一工作簿,加入代码即可。

感谢大佬解疑
回复

使用道具 举报

 楼主| 发表于 2019-11-28 12:22 | 显示全部楼层
蓝桥玄霜 发表于 2019-10-18 14:57
在文件夹中新建一工作簿,加入代码即可。

之前照着其他人写的的直接大力出奇迹挨个输的单元格Sub 清除内容()
With Worksheets("汇总")
  .Range("a3:ZZ1000").ClearContents
End With
End Sub
Sub 汇总123()
Dim arr, brr(1 To 1, 1 To 70)
Dim wb As Workbook
Dim ws As Worksheet
Dim mbrng As Range
Dim mypath$, myname$
Application.DisplayAlerts = False
Application.ScreenUpdating = False
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.xls*")
Do While myname <> ""
  If myname <> ThisWorkbook.Name Then
     Set wb = GetObject(mypath & myname)
     With wb
        With .Worksheets("统计栏")
           arr = .Range("a1:ak22")
           brr(1, 1) = Split(wb.Name, ".")(0)
           brr(1, 2) = arr(7, 2) '
           brr(1, 3) = arr(7, 3) '
           brr(1, 4) = arr(7, 4) '
           brr(1, 5) = arr(7, 5) '
           brr(1, 6) = arr(7, 6) '
           brr(1, 7) = arr(7, 7) '

           brr(1, 8) = arr(17, 22) '
           brr(1, 9) = arr(17, 23) '
           brr(1, 10) = arr(17, 24) '
           brr(1, 11) = arr(17, 25) '
           brr(1, 12) = arr(17, 26) '
           brr(1, 13) = arr(17, 27) '

           brr(1, 14) = arr(7, 8) '
           brr(1, 15) = arr(7, 9)
           brr(1, 16) = arr(7, 10)

           brr(1, 17) = arr(7, 11)
           brr(1, 18) = arr(7, 12)
           brr(1, 19) = arr(7, 13)
           brr(1, 20) = arr(7, 14)
           brr(1, 21) = arr(7, 15)
           brr(1, 22) = arr(7, 16)
           brr(1, 23) = arr(7, 17)
           brr(1, 24) = arr(7, 18)
           brr(1, 25) = arr(7, 19)
           brr(1, 26) = arr(7, 20)
           brr(1, 27) = arr(7, 21)
           brr(1, 28) = arr(7, 22)
           brr(1, 29) = arr(7, 23)

           brr(1, 30) = arr(7, 24)
           brr(1, 31) = arr(7, 25)
           brr(1, 32) = arr(7, 26)
           brr(1, 33) = arr(7, 27)
           brr(1, 34) = arr(7, 28)
           brr(1, 35) = arr(7, 29)
           brr(1, 36) = arr(7, 30)
           brr(1, 37) = arr(7, 31)

           brr(1, 38) = arr(7, 32)
           brr(1, 39) = arr(7, 33)
           brr(1, 40) = arr(7, 34)
           brr(1, 41) = arr(7, 35)
           brr(1, 42) = arr(7, 36)
           brr(1, 43) = arr(7, 37)
           brr(1, 44) = arr(11, 8)
           brr(1, 45) = arr(11, 11)
           brr(1, 46) = arr(11, 12)
           brr(1, 47) = arr(11, 13)
           brr(1, 48) = arr(11, 14)
           brr(1, 49) = arr(11, 15)
           brr(1, 50) = arr(17, 6)
           brr(1, 51) = arr(17, 7)
           brr(1, 52) = arr(17, 8)
           brr(1, 53) = arr(17, 9)
           brr(1, 54) = arr(17, 10)
           brr(1, 55) = arr(17, 11)
           brr(1, 56) = arr(17, 28)









            Set mbrng = ThisWorkbook.Worksheets("汇总").[a65536].End(xlUp).Offset(1, 0)
            mbrng.Resize(UBound(brr), 50) = brr
            Application.CutCopyMode = False
            Erase brr
        End With
     End With
     wb.Close False
  End If
  myname = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "汇总完成"
End Sub



回复

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-8-4 19:31 , Processed in 0.062400 second(s), 6 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表