从其他文件中读取符合条件的数据

zzw20070711 · 发表于 2011-3-27 15:09

每周要对相关数据进行统计，因数据量较大，希望能用VBA解决：

1、附件中材料登记中不是固定的，有可能有三个，也可能只有两个；
2、提取数据时姓名表中姓名也不固定，有可能增加，也可能减少；

目前的做法是打开每一个材料登记表，通过VLOOKUP函数找出符合条件的数据，复制粘贴到一张新表中。但是一方面数据量较大，另一方面碰到材料登记表多时很容易搞漏。
我也试过将多个登记表合并后进行筛选，由于每个材料表中有近三万条记录，最多只能合并2-3个表，无济无事。

请高手帮忙用VBA解决问题，谢谢

zhaogang1960 · 发表于 2011-3-27 15:29

Sub Macro1()
Dim arr, brr(1 To 60000, 1 To 4), d As Object, MyPath$, MyName$, i&, j&, m&
Set d = CreateObject("scripting.dictionary")
arr = Sheets("姓名").[a1].CurrentRegion
For i = 1 To UBound(arr)
      d(arr(i, 1)) = ""
Next
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1).ClearContents
Do While MyName <> ""
      If MyName <> ThisWorkbook.Name Then
         With GetObject(MyPath & MyName)
            arr = .Sheets(1).[a1].CurrentRegion
            .Close False
         End With
         For i = 2 To UBound(arr)
            If d.Exists(arr(i, 3)) Then
                  m = m + 1
                  For j = 1 To 4
                     brr(m, j) = arr(i, j)
                  Next
            End If
         Next
      End If
      MyName = Dir
Loop
[a2].Resize(m, 4) = brr
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 zhaogang1960 于 2011-3-27 15:31 编辑 ]

zhaogang1960 · 发表于 2011-3-27 15:30

附件.rar (15.22 KB, 下载次数: 138)

[ 本帖最后由 zhaogang1960 于 2011-3-27 15:31 编辑 ]

yaojil · 发表于 2011-3-27 15:36

try.......

zzw20070711 · 发表于 2011-3-27 15:44

怎么改后说下标越界？

[ 本帖最后由 zzw20070711 于 2011-3-27 17:34 编辑 ]

zhaogang1960 · 发表于 2011-3-27 15:54

原帖由 zzw20070711 于 2011-3-27 15:44 发表
请问下，实际中我的姓名处于第14列，应该改哪个数值
If d.Exists(arr(i, 3)) Then
                  m = m + 1
                  For j = 1 To 4
                     brr(m, j) = arr(i, j)
   ...

根据需要修改 brr(1 To 60000, 1 To 4)中的4

zzw20070711 · 发表于 2011-3-27 16:03

本人愚笨，改不了。再次麻烦修改一下

zhaogang1960 · 发表于 2011-3-27 16:10

原帖由 zzw20070711 于 2011-3-27 16:03 发表
本人愚笨，改不了。再次麻烦修改一下

Sub qushu()
Dim arr, brr(1 To 65500, 1 To 15), d, mp$, mf$, wb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arr = Sheet2.Range("a1:a" & Sheet2.[a65536].End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
mp = ThisWorkbook.Path & "\"
mf = Dir(mp & "*.xls")
While Len(mf) > 0
If mf <> ThisWorkbook.FullName Then
   Set wb = GetObject(mp & mf)
   arr = wb.Sheets(1).Range("A2:O" & wb.Sheets(1).Range("a65536").End(xlUp).Row)
   For i = 1 To UBound(arr)
         If d.exists(arr(i, 14)) Then
            m = m + 1
            For j = 1 To UBound(arr, 2)
               brr(m, j) = arr(i, j)
            Next
         End If
   Next
End If
mf = Dir
Wend
Set wb = Nothing
Set d = Nothing
Sheet1.[a2:d65536] = ""
If m > 1 Then Sheet1.[a2].Resize(m, 15) = brr
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

zzw20070711 · 发表于 2011-3-27 17:29

感谢老师，运行速度很快
太感谢了

zhaogang1960 · 发表于 2011-3-27 18:13

原帖由 zzw20070711 于 2011-3-27 17:29 发表
感谢老师，运行速度很快
太感谢了

楼主你修改我的代码出错了：
If MyName <> ThisWorkbook.Name Then文件名不等于本文本名

你修改的：
If mf <> ThisWorkbook.FullName Then文件名不等于本文本“全名”，FullName 是包含路径的，会导致这一句无效

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

[求助] 从其他文件中读取符合条件的数据