遍历工作表查找指定数据。

TaintyF · 发表于 2019-3-23 11:29

遍历指定工作薄，并按照要求提前满足条件的数据那一行，大神帮忙看看

chaohuahch · 发表于 2019-3-23 11:39

有点意思，我用SQL语句试一试、

tigertc · 发表于 2019-3-23 11:48

用for each 遍历worksheets,用FIND找姓名字段.find可以获取到地址

lsc900707 · 发表于 2019-3-23 12:05

本帖最后由 lsc900707 于 2019-3-23 13:00 编辑

就是一个跨簿查询的问题。

Sub gj23w98()
Dim crr(1 To 9999, 1 To 4)
brr = [a2].CurrentRegion
Set wb = GetObject(ThisWorkbook.Path & "\" & "原始数据.xlsx")
With wb
      For Each sht In .Sheets
         arr = sht.[a1].CurrentRegion
         For i = 2 To UBound(arr)
            For k = 2 To UBound(brr)
                  If arr(i, 1) = brr(k, 1) Then
                     m = m + 1
                     For j = 1 To 4
                        crr(m, j) = arr(i, j)
                     Next
                  End If
            Next
         Next
      Next
End With
If m Then
      Range("c3:f" & Rows.Count).ClearContents
      [c3].Resize(m, 4) = crr
End If
End Sub

chaohuahch · 发表于 2019-3-23 12:48

代码如下，可惜完成了一般。SQL语句模式和数组也不兼容。in运算符里面的字符串是要单引号的，而正常数据的字符串是双引号的。SQL能否结合数组来运行，看来我还需要考虑清楚。

复制代码

Sub FuYun_SQL()
Dim cnn As Object, rst As Object
Dim Mypath As String, Str_cnn As String, path1$
Dim Sql As String, Sql1 As String
Dim Sht As Worksheet, Sht_name As String
Dim i As Long
Dim wb As Workbook
Dim arr, nRow%, insStr$
With Worksheets("sheet1")
nRow = .Cells(.Rows.Count, 1).End(3).Row
arr = .Range("a3:a" & nRow)
End With
Set cnn = CreateObject("adodb.connection")
path1 = "\原始数据.xlsx"
Mypath = ThisWorkbook.Path & path1
If Application.Version < 12 Then
Str_cnn = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & Mypath
Else
Str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath
End If
cnn.Open Str_cnn
Set wb = GetObject(Mypath)
Sql1 = "SELECT 姓名,数学成绩,语文成绩,英语成绩"
For Each Sht In wb.Worksheets
Sht_name = Sht.Name
If Sht_name <> ActiveSheet.Name Then
Sql = Sql & Sql1 & " FROM [" & Sht_name & "$] where 姓名 in('小红','小白') UNION ALL "
End If
Next
Sql = Left(Sql, Len(Sql) - 11) & "ORDER BY 姓名"
Set rst = cnn.Execute(Sql)
Cells.ClearContents
Range("a2").CopyFromRecordset rst
cnn.Close
Set cnn = Nothing
End Sub

复制代码

qingc0221 · 发表于 2019-3-23 12:53

放在汇总工作簿的sheet1中
如果要放到公共模块中,需要将下面的Me改为thisworkbook.sheets("sheet1")

Sub main()
Dim LastRow As Long, i As Long
Dim strCrit As String, strSQL As String
Dim fName As String
Dim conn As Object, Rst As Object
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
If LastRow = 2 Then '没有输入查询条件
If (MsgBox("查询条件为空,是否输出所有数据?", vbYesNo)) = vbYes Then '输出所有数据
strCrit = ";"
Else '取消查询
Exit Sub
End If
ElseIf LastRow = 3 Then '只有一个条件
strCrit = " WHERE 姓名='" & Range("A3").Value & "';"
Else '多个查询条件
For i = 3 To LastRow
If strCrit = "" Then
strCrit = " WHERE 姓名 in ('" & Cells(i, 1).Value & "'"
Else
strCrit = strCrit & ",'" & Cells(i, 1).Value & "'"
End If
Next i
strCrit = strCrit & ")"
End If
'删除原有查询结果
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
If LastRow > 2 Then
Range("C3:F" & LastRow).ClearContents
End If
fName = ThisWorkbook.Path & "\原始数据.xlsx"
Set conn = CreateObject("ADODB.Connection")
Set Rst = CreateObject("ADODB.Recordset")
conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & fName
Set Rst = conn.openschema(20)
Do While Not Rst.EOF
If Rst!TABLE_TYPE = "TABLE" Then
strSQL = "SELECT * FROM [" & Rst!TABLE_NAME & "]" & strCrit
LastRow = Me.Cells(Me.Rows.Count, 3).End(xlUp).Row
Me.Cells(LastRow + 1, "C").CopyFromRecordset conn.Execute(strSQL)
End If
Rst.movenext
Loop
Set Rst = Nothing
conn.Close
Set conn = Nothing
MsgBox "完成"
End Sub

复制代码

qingc0221 · 发表于 2019-3-23 12:55

还有一个问题就是数据源中的工作表名含有".",需要删掉,否则出错

chaohuahch · 发表于 2019-3-23 14:46

qingc0221 发表于 2019-3-23 12:53
放在汇总工作簿的sheet1中
如果要放到公共模块中,需要将下面的Me改为thisworkbook.sheets("sheet1")

看来，这种还是不适合用SQL语句。不过你处理where的方法，我需要学习。

TaintyF · 发表于 2019-3-23 16:03

都是神人，膜拜

爱沉浮 · 发表于 2019-3-24 13:55

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刚入门，有瑕疵的地方，欢迎大家指正

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

[求助] 遍历工作表查找指定数据。

最新热点 /1