|
- Sub 查找多个值() '查找多个值
- Dim Path As String
- Dim findstr As String
- Dim findarr
- Range("c3:f2000").ClearContents
- Path = ThisWorkbook.Path & IIf(Right(ThisWorkbook.Path, 1) = "", "", "") '取得路径,为下一步打开工作簿做准备
- Application.ScreenUpdating = False
- Set wb = Workbooks.Open(Filename:=Path & "原始数据.xlsx") '打开该路径下的工作簿,方便提取原始数据
- Dim sht As Worksheet
- Dim rng As Range
- Dim rng2 As Range
- Dim Fistadd As String
- Dim Nofind As String
- Dim Numb As Integer
- Dim arr()
- Set rng2 = ThisWorkbook.Sheets("sheet1").Range("a3:a" & ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row) '要查找的值,该值可能存在多个,将每个值存入数组
-
- If rng2.Count = 1 Then '当rng2为当个单元格时,复制给arr总是报错,没办法用只能用if区分处理了
- ReDim findarr(1 To 1, 1 To 1) '当单个单元格时,先用redim重新定义数组维度,然后复制
- findarr(1, 1) = rng2.Value
- Else '让rng2为单元格区域是一次性复制
- findarr = rng2.Value
-
- End If
-
- For j = 1 To UBound(findarr, 1) '先从第一要个值开始查找,然后循环遍历后,再查找第二个
- Debug.Print LBound(findarr, 1)
- findstr = findarr(j, 1)
- For Each sht In ActiveWorkbook.Sheets
- Set rng = sht.Range("a1").CurrentRegion.Find(findstr)
- If Not rng Is Nothing Then
- Fistadd = sht.Range("a1").CurrentRegion.Find(findstr).Address
- Do
- Item = Item + 1
- ReDim Preserve arr(1 To 4, 1 To Item)
- arr(1, Item) = rng.Value '姓名
- arr(2, Item) = rng.Offset(0, 1).Value '数学成绩
- arr(3, Item) = rng.Offset(0, 2).Value '语文成绩
- arr(4, Item) = rng.Offset(0, 3).Value '英语成绩
- Set rng = sht.Range("a1").CurrentRegion.FindNext(rng)
- If rng.Address = Fistadd Then Exit Do
- Loop
-
- Else
-
- Rem 当查找的名称在原始数据表里的所有工作簿中都没查找到,则记入未查找的名称,最后通过msgbox弹出
- Numb = Numb + 1
- If Numb = ActiveWorkbook.Sheets.Count Then '当Numb等于工作表个数时,则说明所有的工作表都没查到此数
- Nofind = findstr & "," & Nofind
- Numb = 0 'numb等于工作表个数时,最后要变为0,一遍再次循环使用,如果清零的话Numb会累加,比如实际中有两个没找到的,那么
- End If '前文的Numb就等于两倍的工作表个数了,这样这要有二个以上(包括两个)的名字没找到,这个会使Numb > ActiveWorkbook.Sheets.Count,这样等式就永远不相等了
- Rem ******************************************************************************************
-
-
- End If
- Next
- Next
- On Error Resume Next '当所有姓名都没查到是,数组为空这时u=ubound(arr,2)会报错,本来想用Len(Join(arr, ",")) = 0 来判断数组是不是为空。
- u = UBound(arr, 2) '但是join函数用于一维数组,这条路行不通,查了半天还是得用on error resume next 和if err.number来处理
- If Err.Number <> 0 Then
- ActiveWorkbook.Close fasle
- Application.ScreenUpdating = True
- MsgBox "所有姓名查找不到"
- Else
- ActiveWorkbook.Close fasle
- Application.ScreenUpdating = True
- ThisWorkbook.Sheets("sheet1").Range("c3").Resize(u, 4) = WorksheetFunction.Transpose(arr)
- If Len(Nofind) > 0 Then MsgBox "下列姓名查询不到:" & Nofind
- End If
- End Sub
复制代码 vba刚入门,有瑕疵的地方,欢迎大家指正
|
|