vba查不到数据，且如何实现找不到工号的位置后面保留空值

lihui8171012

类的代码：
Sub mingling(sq As String, f As String, Rg As String)
   Dim conn As Object
   Set conn = CreateObject("adodb.connection")
   conn.Open "Provider=microsoft.ACE.OLEDB.12.0;extended properties=EXCEL 12.0;data source=" & f
   ActiveSheet.Range(Rg).CopyFromRecordset conn.Execute(sq)
   conn.Close
   Set conn = Nothing
End Sub

模块代码：
Sub shishi()
   Dim cx As New 类1, pt$, f$, sql$, r&
   pt = ThisWorkbook.Path & "\数据收集\"
   Application.ScreenUpdating = False
   [c2:g1000].ClearContents
   arr = Range("b2").CurrentRegion
   For x = 1 To UBound(arr)
       If arr(x, 1) <> "" Then
          sql = "select 姓名,部门,入职日期,培训情况 from [sheet1$b1:f] where 工号='" & arr(x, 1) & "'"
          f = Dir(pt & "*.xls*")
          Do While f <> ""
             r = Cells(65536, 3).End(3).Row + 1
             cx.mingling sql, pt & f, "c" & r
             f = Dir
          Loop
       End If
    Next
    Application.ScreenUpdating = True
End Sub

LMY123

参考:

1. Sub 复制数据用()
   
2. For X = 2 To Range("A65536").End(3).Row
   
3.     S = S & Cells(X, 1)
   
4. Next
   
5. Cells(1, 12) = Mid(S, 1, Len(S) - 1)
   
6. End Sub
   
7. Sub shishi3()
   
8. Dim arr
   
9.    Dim cx As New 类1, pt$, f$, sql$, r&
   
10.    pt = ThisWorkbook.Path & "\数据收集"
    
11.    Application.ScreenUpdating = False
    
12.    [c2:g1000].ClearContents
    
13.    Cells(1, 12) = T
    
14.           sql = "select 姓名,部门,进厂时间,培训情况 from [sheet1$b1:f] where 工号 in ('" & [b2] & "','" & [b3] & "','" & [b4] & "','" & [b5] & "','" & [b6] & "','" & [b7] & "','" & [b8] & "','" & [b9] & "','" & [b10] & "','" & [b11] & "','" & [b12] & "','" & [b13] & "','" & [b14] & "','" & [b15] & "','" & [b16] & "','" & [b17] & "','" & [b18] & "')"
    
15.           f = Dir(pt & "*.xls*")
    
16.           Do While f <> ""
    
17.              r = Cells(65536, 3).End(3).Row + 1
    
18.              cx.mingling sql, pt & f, "c" & r
    
19.              f = Dir
    
20.           Loop
    
21. 
    
22.     Application.ScreenUpdating = True
    
23.     Cells(1, 12) = T
    
24. End Sub

复制代码

LMY123

数据统计表.rar (21.75 KB, 下载次数: 17)

2016-10-5 19:10 上传

点击文件名下载附件

补充内容 (2019-1-4 19:59):
单夹_多薄_指定表_单条件匹配_ADO加字典,已入库。

补充内容 (2019-1-4 20:03):
Sub 单夹_多薄_指定表_单条件匹配_ADO加类模块，已入库。

lihui8171012

LMY123 发表于 2016-10-5 19:11

你的这个还是不行，只能统计18个工号，我一个月大概有10000个工号左右，另外，如果工号不存在，你的也没有办法空着，都是覆盖了！

duquancai

看见你这么执着的份上，请下载附件进行测试》》》》》》》》》》》

lihui8171012

duquancai 发表于 2016-10-5 20:35
看见你这么执着的份上，请下载附件进行测试》》》》》》》》》》》

老师，不好意思，十分感谢！！！但是我基本复制你的，怎么就没有反应呢？上面附件哪里有问题？能够指出来吗？万分感谢！！！

duquancai

lihui8171012 发表于 2016-10-5 20:45
老师，不好意思，十分感谢！！！但是我基本复制你的，怎么就没有反应呢？上面附件哪里有问题？能够指出来 ...

你看我上传的附件吧！我的附件运行有问题吗？

zhaogang1960

楼主邀请收到，本题目使用数组加字典加SQL法速度更快，请参考：
Sub 数组加字典加SQL()
    Dim cnn As Object, rs As Object, p$, f$, SQL$, arr, i&, j&, r, b As Boolean, d As Object
    Set d = CreateObject("scripting.dictionary")
    d.CompareMode = 1 '不区别大小写
    arr = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    ReDim brr(1 To i - 1, 2 To 5)
    Set cnn = CreateObject("ADODB.Connection")
    p = ThisWorkbook.Path & "\数据收集\"
    f = Dir(p & "*.xls")
    Do While f <> ""
        If Not b Then
            cnn.Open "Provider = Microsoft.ace.Oledb.12.0;Extended Properties =Excel 12.0;Data Source =" & p & f
            SQL = "select * from [Sheet1$]"
            b = True
        Else
            SQL = "select * from [Excel 12.0;Database=" & p & f & ";].[Sheet1$]"
        End If
        Set rs = cnn.Execute(SQL)
        arr = rs.GetRows
        For i = 0 To UBound(arr, 2)
            r = d(arr(1, i))
            If r <> "" Then
                For j = 2 To 5
                    brr(r, j) = arr(j, i)
                Next
            End If
        Next
        f = Dir
    Loop
    Range("C2").Resize(UBound(brr), 4) = brr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

zhaogang1960

楼主邀请收到，刚上传代码区要审核，待会儿审核后就会出现，现上传附件：
请注意，查询时不区别大小写，如果要区分请删除d.CompareMode = 1
需要帮助.rar (30.43 KB, 下载次数: 87)

2016-10-5 21:25 上传

点击文件名下载附件

lsc900707

zhaogang1960 发表于 2016-10-5 21:26
楼主邀请收到，刚上传代码区要审核，待会儿审核后就会出现，现上传附件：
请注意，查询时不区别大小写，如 ...

赵老师：我测试时只有一个工号查询时就提示“类型不匹配”，两个以上就正常了>>>>>>>>