“样本文件夹”下有很多工作薄且格式都一样，以前用VLOOKUP查询速度很慢，现要求在...

cuishunde · 发表于 2014-12-31 19:30

本帖最后由 cuishunde 于 2015-1-1 12:22 编辑

[tr] [/tr]
[tr] [/tr]
[tr] [/tr]
[tr] [/tr]

“样本文件夹”下有很多工作薄且格式都一样，以前用VLOOKUP查询速度很慢，现要求在不打开“样本文件夹”下的工作簿，在查询工作薄中输入手机号码后就能查询“样本文件夹”下的所有工作簿，如果有就显示在黄色区域，如果没有就显示为空

(新)文件.rar (6.47 KB, 下载次数: 4)

dsmch · 发表于 2014-12-31 22:33

Sub Macro1()
Dim mypath$, wj$, wb As Workbook
Dim arr, brr, i&, s&
Application.ScreenUpdating = False
ReDim brr(1 To 1000, 1 To 4)
gjz = [a2]
mypath = ThisWorkbook.Path & "\样本"
wj = Dir(mypath & "*.xls*")
Do While wj <> ""
Set wb = GetObject(mypath & wj)
arr = wb.Sheets(1).Range("a1").CurrentRegion
wb.Close 0
For i = 2 To UBound(arr)
If arr(i, 4) Like "*" & gjz & "*" Then
s = s + 1
brr(s, 1) = arr(i, 1)
brr(s, 2) = arr(i, 2)
brr(s, 3) = arr(i, 3)
brr(s, 4) = arr(i, 5)
End If
Next
wj = Dir
Loop
If s > 0 Then Range("b2").Resize(s, 4) = brr
Application.ScreenUpdating = True
End Sub

复制代码

dsmch · 发表于 2014-12-31 22:34

………………

cuishunde · 发表于 2015-1-1 11:32

dsmch 发表于 2014-12-31 22:34
………………

非常感谢，你的编码很符合我的要求，由于我是一个菜鸟，麻烦你在该一下编码，我把附件在重传一下，谢谢，编码中能否控制一下如是查询表中没有电话号就不提取数据呀（如果不好加可以不加

文件.rar (6.47 KB, 下载次数: 2)

dsmch · 发表于 2015-1-1 12:01

………………

cuishunde · 发表于 2015-1-1 12:17

dsmch 发表于 2015-1-1 12:01
………………

Sub 查询()
Dim sht As Worksheet, drow%, i%, j%, Arr, Brr, d, Crr
Set d = CreateObject("scripting.dictionary")
Dim r As Long, c As Long
r = 2
Application.ScreenUpdating = False '屏幕闪烁关闭
Dim filename As String, wb As Workbook, Erow As Long
Dim fn As String
'  On Error GoTo VeryEnd
filename = Dir(ThisWorkbook.Path & "\样本\*.xls")    '对文件夹内的工作簿进行循环，循环查找的格式  *.xls
' MsgBox filename
Do While filename <> ""
      If filename <> ThisWorkbook.Name Then          '判断文件是否是本工作簿
         '  Erow = Range("A1").End(xlDown).Row '取得汇总表中第一条空行行号
         '  MsgBox "erow=" & Erow
         fn = ThisWorkbook.Path & "\样本\" & filename '取得循环符合条件工作簿的  文件夹地址，赋值给fn 这个变量

         ' MsgBox "现在汇总的工作簿是fn= " & fn

         Set wb = GetObject(fn)                         '将fn代表的工作簿对象赋给变量
         '  MsgBox wb.Name
         Set sht = wb.Worksheets(1)                      '汇总的是第1张工作表
         '将数据表中的记录保存在arr数组里
         Arr = sht.Range("a2:e" & sht.Range("a65536").End(3).Row)          '将结果存放在定义好的数组arr中
         For i = 1 To UBound(Arr)
            d(Arr(i, 4)) = Arr(i, 1) & "@" & Arr(i, 2) & "@" & Arr(i, 3) & "@" & Arr(i, 5)
         Next
         Erase Arr
         wb.Close False
      End If
      filename = Dir    '进行下一步的循环
Loop
Dim tt As String
' MsgBox d.Count
With Worksheets("sheet1")
      ' .Range("l2").Resize(d.Count, 1) = Application.Transpose(d.keys)
      '  .Range("m2").Resize(d.Count, 1) = Application.Transpose(d.items)

      drow = .Range("a65536").End(3).Row
      ' MsgBox drow
      Brr = .Range("a2:e" & drow)
      .Range("l17").Resize(UBound(Brr), 5) = Brr
      For i = 1 To UBound(Brr)
         tt = "@" & CStr(Brr(i, 1))
         '  MsgBox tt & " " & d(tt)
         Crr = Split(d(Brr(i, 1)), "@")
         ' MsgBox UBound(Crr)
         If UBound(Crr) > 0 Then
            For j = 0 To 3
                  Brr(i, j + 2) = Crr(j)
            Next
         End If
      Next
      .Range("a2").Resize(UBound(Brr), 5) = Brr
End With

VeryEnd:
Application.ScreenUpdating = True

End Sub

能否把上面代码改成附件中的格式，谢谢

(新)文件.rar (6.47 KB, 下载次数: 0)

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

“样本文件夹”下有很多工作薄且格式都一样，以前用VLOOKUP查询速度很慢，现要求在...

相关帖子