Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 6207|回复: 25

[已解决]多工作薄数据汇总

[复制链接]
发表于 2016-1-19 16:26 | 显示全部楼层 |阅读模式
本帖最后由 安全网 于 2016-1-21 16:39 编辑

求助对多个工作薄内指定位置的数据汇总,具体见附件
最佳答案
2016-1-21 15:59
Sub 导入文件()
    Application.ScreenUpdating = False
    Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
    Filename = Dir(ThisWorkbook.Path & "\*.xls")
    arr = [a2:p2]       '本表第二行数据,用于确定在打开文件中查找内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
    ReDim brr(1 To 100, 1 To UBound(arr, 2))     '结果数组
    r = [a65536].End(3).Row + 1      '需要导入数据的起始行
    s = Val(Cells(r - 1, 1))     '已有数据的序号
    Do While Filename <> ""
        If Filename <> ThisWorkbook.Name Then
            fn = ThisWorkbook.Path & "\" & Filename
            Set wb = Workbooks.Open(fn, Password:="123")      '打开文件,密码123
            Set Sht = wb.Worksheets(1)     '打开文件的第一个工作表
            n = n + 1
            brr(n, 1) = s + n: brr(n, 2) = Sht.[c2]: brr(n, 3) = Sht.[M2]       '序号、日期、流水号
            For j = 4 To UBound(arr, 2)
                x = arr(1, j)     '要查找的内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
                Set xRng = Sht.UsedRange.Find(x, lookat:=xlWhole)   '在打开工作表中查找第二行各列的内容
                If Not xRng Is Nothing Then        '如果找到
                    If j <= 10 Then brr(n, j) = xRng.Offset(0, 1) Else brr(n, j) = xRng.Offset(1, 0)        '读取相应内容进数组
                End If
            Next
            wb.Close False
        End If
        Filename = Dir        '读取下一个文件
    Loop
    Set Sht = Nothing
    Cells(r, 1).Resize(n, UBound(brr, 2)) = brr           '显示结果
    Application.ScreenUpdating = True
End Sub
 楼主| 发表于 2016-1-19 17:07 | 显示全部楼层
是附件没有点击确定

多工作薄数据汇总.rar

210.64 KB, 下载次数: 29

回复

使用道具 举报

 楼主| 发表于 2016-1-20 08:56 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2016-1-21 08:19 | 显示全部楼层
请问高手是否能实现?
回复

使用道具 举报

发表于 2016-1-21 10:20 | 显示全部楼层
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
  4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
  5.     arr = [a2:m2]
  6.     ReDim brr(1 To 100, 1 To UBound(arr, 2))
  7.     r = [a65536].End(3).Row + 1      '需要导入数据的起始行
  8.     s = Val(Cells(r - 1, 1))     '已有数据的序号
  9.     Do While Filename <> ""
  10.         If Filename <> ThisWorkbook.Name Then
  11.             fn = ThisWorkbook.Path & "" & Filename
  12.             Set wb = Workbooks.Open(fn)
  13.             Set Sht = wb.Worksheets(1)
  14.             n = n + 1
  15.             brr(n, 1) = s + n: brr(n, 2) = Sht.[c2]: brr(n, 3) = Sht.[M2]
  16.             For j = 4 To UBound(arr, 2)
  17.                 x = arr(1, j)     '要查找的内容
  18.                 Set xRng = Sht.UsedRange.Find(x, lookat:=xlWhole)
  19.                 If Not xRng Is Nothing Then
  20.                     If j <= 7 Then brr(n, j) = xRng.Offset(0, 1) Else brr(n, j) = xRng.Offset(1, 0)
  21.                 End If
  22.             Next
  23.             wb.Close False
  24.         End If
  25.         Filename = Dir
  26.     Loop
  27.     Set Sht = Nothing
  28.     Cells(r, 1).Resize(n, UBound(brr, 2)) = brr
  29.     Application.ScreenUpdating = True
  30. End Sub
复制代码

多工作薄数据汇总.rar

221.1 KB, 下载次数: 38

回复

使用道具 举报

 楼主| 发表于 2016-1-21 11:01 | 显示全部楼层
grf1973 发表于 2016-1-21 10:20

如果每个工作薄都像图片这样设置了密码,密码都是:123,能否不用手动输入密码就可以导入数据。还有能否解释下代码?谢谢!
QQ图片20160121105246.png
回复

使用道具 举报

发表于 2016-1-21 14:19 | 显示全部楼层
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
  4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
  5.     arr = [a2:m2]       '本表第二行数据,用于确定在打开文件中查找内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
  6.     ReDim brr(1 To 100, 1 To UBound(arr, 2))     '结果数组
  7.     r = [a65536].End(3).Row + 1      '需要导入数据的起始行
  8.     s = Val(Cells(r - 1, 1))     '已有数据的序号
  9.     Do While Filename <> ""
  10.         If Filename <> ThisWorkbook.Name Then
  11.             fn = ThisWorkbook.Path & "" & Filename
  12.             Set wb = Workbooks.Open(fn, Password:="123")      '打开文件,密码123
  13.             Set Sht = wb.Worksheets(1)     '打开文件的第一个工作表
  14.             n = n + 1
  15.             brr(n, 1) = s + n: brr(n, 2) = Sht.[c2]: brr(n, 3) = Sht.[M2]       '序号、日期、流水号
  16.             For j = 4 To UBound(arr, 2)
  17.                 x = arr(1, j)     '要查找的内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
  18.                 Set xRng = Sht.UsedRange.Find(x, lookat:=xlWhole)   '在打开工作表中查找第二行各列的内容
  19.                 If Not xRng Is Nothing Then        '如果找到
  20.                     If j <= 7 Then brr(n, j) = xRng.Offset(0, 1) Else brr(n, j) = xRng.Offset(1, 0)        '读取相应内容进数组
  21.                 End If
  22.             Next
  23.             wb.Close False
  24.         End If
  25.         Filename = Dir        '读取下一个文件
  26.     Loop
  27.     Set Sht = Nothing
  28.     Cells(r, 1).Resize(n, UBound(brr, 2)) = brr           '显示结果
  29.     Application.ScreenUpdating = True
  30. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-1-21 15:04 | 显示全部楼层
grf1973 发表于 2016-1-21 14:19

如果2个分表新增加了内存条,显卡、主板等内容,导入的汇总表里面也要增加这3项或者更多统计项,怎么样修改代码参数
QQ图片20160121145559.png
回复

使用道具 举报

发表于 2016-1-21 15:59 | 显示全部楼层    本楼为最佳答案   
Sub 导入文件()
    Application.ScreenUpdating = False
    Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
    Filename = Dir(ThisWorkbook.Path & "\*.xls")
    arr = [a2:p2]       '本表第二行数据,用于确定在打开文件中查找内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
    ReDim brr(1 To 100, 1 To UBound(arr, 2))     '结果数组
    r = [a65536].End(3).Row + 1      '需要导入数据的起始行
    s = Val(Cells(r - 1, 1))     '已有数据的序号
    Do While Filename <> ""
        If Filename <> ThisWorkbook.Name Then
            fn = ThisWorkbook.Path & "\" & Filename
            Set wb = Workbooks.Open(fn, Password:="123")      '打开文件,密码123
            Set Sht = wb.Worksheets(1)     '打开文件的第一个工作表
            n = n + 1
            brr(n, 1) = s + n: brr(n, 2) = Sht.[c2]: brr(n, 3) = Sht.[M2]       '序号、日期、流水号
            For j = 4 To UBound(arr, 2)
                x = arr(1, j)     '要查找的内容(WDA、键盘、鼠标、主机、折后a、折后b、折后c、折后d、折后e、折后f)
                Set xRng = Sht.UsedRange.Find(x, lookat:=xlWhole)   '在打开工作表中查找第二行各列的内容
                If Not xRng Is Nothing Then        '如果找到
                    If j <= 10 Then brr(n, j) = xRng.Offset(0, 1) Else brr(n, j) = xRng.Offset(1, 0)        '读取相应内容进数组
                End If
            Next
            wb.Close False
        End If
        Filename = Dir        '读取下一个文件
    Loop
    Set Sht = Nothing
    Cells(r, 1).Resize(n, UBound(brr, 2)) = brr           '显示结果
    Application.ScreenUpdating = True
End Sub
回复

使用道具 举报

 楼主| 发表于 2016-1-22 08:50 | 显示全部楼层
grf1973 发表于 2016-1-21 15:59
Sub 导入文件()
    Application.ScreenUpdating = False
    Dim Filename, wb As Workbook, Sht As Wor ...

不好意思!还有个问题要咨询下,图片横向和竖向的这个数值是通过那个代码导入到工作薄内的。还有我想把折后A.B.C....放在流水码后面怎么修改代码。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-28 21:28 , Processed in 0.318820 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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