当前位置：首页 → 问答吧 → 如何在VBA中查找指定的值（十万火急）

如何在VBA中查找指定的值（十万火急）

时间：2011-08-06

来源：互联网

我现在有两个工作簿，其中一个是数据源，用于存放各个地区的数据。另外一个工作簿用来存放
指定序号的对应查找结果。现在想用VBA完成查找结果这张工作簿。还望各位大侠给予答复，万分感谢。
附上附件，小弟在线等答复

附件

如何在VBA中使用查找函数.zip(9.95 KB)

2011-8-6 09:05, 下载次数: 17

作者: kay520042 发布时间: 2011-08-06

Sub Macro1()
Dim Wb As Workbook, arr, brr, i, j, m
Dim Temp As String
   Application.ScreenUpdating = False
   Temp = ThisWorkbook.Path & "\数据源.xls"
   Set Wb = GetObject(Temp)
      arr = Wb.Sheets(1).Range("A1").CurrentRegion
         'Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
         Wb.Close False
   Set Wb = Nothing
   Application.ScreenUpdating = True
MsgBox arr(1, 1)
brr = Sheet1.Range("a1").CurrentRegion
For i = 2 To UBound(brr, 1)
   For j = 1 To UBound(arr, 1)
      If brr(i, 1) = brr(j, 1) Then

         For m = 2 To UBound(brr, 2)
               brr(j, m) = arr(i, m)
         Next
         Exit For
      End If
   Next
Next
Sheet1.Range("a1").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

看看可以不

作者: Qinqinjiang 发布时间: 2011-08-06

你的代码可以实现数据源的第一张表格，但是我数据源里面有很多的城市，也要遍历其他的城市怎么修改啊？我运行你的代码之后，发现查找结果表并没用填满啊？

作者: kay520042 发布时间: 2011-08-06

多个表就再加个FOR 循环

自己折腾一下咯

作者: Qinqinjiang 发布时间: 2011-08-06

我再补充一点，查找结果工作簿中的序号它是一个比对值，并不是单纯的顺序，实际上就相当于VLOOKUP函数中的第一个参数，要将对应序号的值填入到工作簿啊。你的代码并不能实现。还望赐教啊

作者: kay520042 发布时间: 2011-08-06

Sub MyLookup()
Dim I As Integer, J As Integer, K As Integer, N As Integer
Dim Arr, Brr(), d
Dim Sh As Worksheet
Dim PathOfFile As String, NameOfFile As String
Application.Volatile
PathOfFile = ThisWorkbook.Path & "\"
NameOfFile = "数据源.xls"
On Error Resume Next
With GetObject(PathOfFile & NameOfFile)
If Err <> 0 Then
      GoTo endValue
      End If
Set d = CreateObject("Scripting.Dictionary") '建立字典对象
For Each Sh In Workbooks("数据源.xls").Worksheets
      If Sh.Range("A1") <> "" Then
         Arr = Sh.Range("A1").CurrentRegion
         I = Sh.UsedRange.Columns.Count
            For J = 2 To UBound(Arr, 1)
                  N = N + 1
                  d(Arr(J, 1)) = N '建议索引
                  ReDim Preserve Brr(1 To I, 1 To N)
                     For K = 1 To I '数组赋值
                        Brr(K, N) = Arr(J, K)
                     Next K
            Next J
         End If
      Next Sh
.Close False
End With
Range("B2:C" & Range("A65536").End(3).Row).ClearContents
For I = 2 To Range("A65536").End(3).Row
         If Not d.exists(Cells(I, 1).Value) Then
         Cells(I, 2) = "未查询到"
         Cells(I, 3) = "未查询到"
         Else
         Cells(I, 2) = Brr(2, d(Cells(I, 1).Value)) '使用字典查例号
   Cells(I, 3) = Brr(3, d(Cells(I, 1).Value))
         End If
      Next I
endValue:
End Sub

附件

如何在VBA中使用查找函数.rar(18.92 KB)

2011-8-6 12:01, 下载次数: 1

作者: xhqxiao 发布时间: 2011-08-06

十分感谢xhqxiao 老师，你的代码很实用，效果也是和我预期的一样。只是我看不太明白你的代码，能否解析一下呢。十分感谢。

作者: kay520042 发布时间: 2011-08-06

Sub zhz3230()
Dim Wb As Workbook, arr, brr, i, j, m
Dim Temp As String
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
   Application.ScreenUpdating = False
   Temp = ThisWorkbook.Path & "\数据源.xls"
   Set Wb = GetObject(Temp)
   For n = 1 To Wb.Sheets.Count
   arr = Wb.Sheets(n).Range("a2:c" & Wb.Sheets(n).Range("a65536").End(xlUp).Row)
   For x = 1 To UBound(arr)
   d(arr(x, 1)) = arr(x, 2)
   d1(arr(x, 1)) = arr(x, 3)
   Next
   Next
   Wb.Close False
   Set Wb = Nothing
For i = 2 To Sheets("查找结果").Range("a65536").End(xlUp).Row
If d.exists(Sheets("查找结果").Cells(i, 1).Value) Then
Sheets("查找结果").Cells(i, 2) = d(Sheets("查找结果").Cells(i, 1).Value)
Sheets("查找结果").Cells(i, 3) = d1(Sheets("查找结果").Cells(i, 1).Value)
Else
Sheets("查找结果").Cells(i, 2) = "未查找结果"
Sheets("查找结果").Cells(i, 3) = "未查找结果"
End If
Next
Application.ScreenUpdating = True
End Sub

作者: zhz3230 发布时间: 2011-08-06

还有一个问题就是假如数据源和查找表的列数增多了，这段代码需要更改吗？或者说我只想得到自己制定的列的值，可以实现吗？效果和VLOOKUP一样。如果数据源的序号不在第一列了又改怎么处理呢？

作者: kay520042 发布时间: 2011-08-06

还有一个问题就是假如数据源和查找表的列数增多了，这段代码需要更改吗？否则说我只想得到自己制定的列的值，可以实现吗？

作者: kay520042 发布时间: 2011-08-06

要修改，如果列多可以用另一种做法（单字典即可）

作者: zhz3230 发布时间: 2011-08-06

复制内容到剪贴板

代码:

Sub zdgx()
Dim Arr, myPath$, myName$, sh As Worksheet
Dim m&, funm$, n&, Sht As Worksheet
Dim d, k, t, Brr
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
funm = "查找结果表.xls"
Set Sht = ActiveSheet
Sht.[b2:c1000].ClearContents
Sht.[a2:c1000].Borders.LineStyle = xlNone
myPath = ThisWorkbook.Path & "\"
myName = Dir(myPath & "数据源.xls")
n = 2
Do While myName <> "" And myName <> funm
      With GetObject(myPath & myName)
         Set wb = Workbooks(myName)
         For Each sh In wb.Sheets
            m = sh.[a65536].End(xlUp).Row
            If m < 2 Then GoTo 100
            Arr = sh.Range("a2:c" & m)
            For i = 1 To UBound(Arr)
                  d(Arr(i, 1)) = Arr(i, 2) & "|" & Arr(i, 3)
            Next
         Next
100:          .Close False
      End With
      myName = Dir
Loop
k = d.keys
t = d.items
Brr = Sht.[a1].CurrentRegion
For i = 0 To UBound(k)
      Set r1 = Sht.[a:a].Find(k(i), , , 1)
      If Not r1 Is Nothing Then
         Brr(r1.Row - 1, 2) = Split(t(i), "|")(0)
         Brr(r1.Row - 1, 3) = Split(t(i), "|")(1)
      End If
Next
Sht.Range("b2").Resize(UBound(Brr), 1) = Application.Index(Brr, 0, 2)
Sht.Range("c2").Resize(UBound(Brr), 1) = Application.Index(Brr, 0, 3)
Sht.Range("a1:c" & UBound(Brr)).Borders.LineStyle = 1
Set d = Nothing
Application.ScreenUpdating = True
End Sub

作者: 蓝桥玄霜发布时间: 2011-08-06

请见附件。

附件

查找结果表0806.rar(17.09 KB)

2011-8-6 12:27, 下载次数: 2

作者: 蓝桥玄霜发布时间: 2011-08-06

我重新上传一个附件，就是把之前没有考虑到的因素加进去了，希望zhz3230老师解答

附件

如何在VBA中使用查找函数.zip(17.41 KB)

2011-8-6 12:31, 下载次数: 4

作者: kay520042 发布时间: 2011-08-06

我重新上传一个附件，就是把之前没有考虑到的因素加进去了，希望蓝桥玄霜老师解答

附件

如何在VBA中使用查找函数.zip(17.41 KB)

2011-8-6 12:38, 下载次数: 6

作者: kay520042 发布时间: 2011-08-06

Sub zhz3230()
Dim Wb As Workbook, arr, brr, i, j, m
Dim Temp As String
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
   Application.ScreenUpdating = False
   Temp = ThisWorkbook.Path & "\数据源.xls"
   Set Wb = GetObject(Temp)
   For N = 1 To Wb.Sheets.Count
   arr = Wb.Sheets(N).Range("b2:e" & Wb.Sheets(N).Range("b65536").End(xlUp).Row)
   For x = 1 To UBound(arr)
   d(arr(x, 1)) = arr(x, 2)
   d1(arr(x, 1)) = arr(x, 4)
   Next
   Next
   Wb.Close False
   Set Wb = Nothing
For i = 2 To Sheets("查找结果").Range("a65536").End(xlUp).Row
If d.exists(Sheets("查找结果").Cells(i, 1).Value) Then
Sheets("查找结果").Cells(i, 2) = d(Sheets("查找结果").Cells(i, 1).Value)
Sheets("查找结果").Cells(i, 3) = d1(Sheets("查找结果").Cells(i, 1).Value)
Else
Sheets("查找结果").Cells(i, 2) = "未查找结果"
Sheets("查找结果").Cells(i, 3) = "未查找结果"
End If
Next
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 zhz3230 于 2011-8-6 12:52 编辑 ]

作者: zhz3230 发布时间: 2011-08-06