VBA+ADO+SQL抓取指定文件表格中地址为A1、A2的单元格的数据

windgod001

求组：
      用VBA编写代码：运用VBA+ADO+SQL合并抓取通过对话框选取的多个excel文件中名为“sheet1”中A3:G区域“姓名”和“身份证号”字段的所有非空单元格数据，同时在每次抓文件过来的时候在记录集增加两列，一列的字段名为“工程名称”，数据从源文件sheet1表格地址为A2的单元格获取，另一列的字段名为“时间”，数据从源文件sheet1表格地址为A1的单元格前面的"XXXX年XX月XX日至XXXX年XX月XX日"。
问题：目前代码能实现“运用VBA+ADO+SQL合并抓取通过对话框选取的多个excel文件中名为“sheet1”中A3:G区域“姓名”和“身份证号”字段的所有非空单元格数据”，后面部分的不会写，试过"SELECT [序号],[姓名],[身份证号],(select [a2] from [sheet1$]) as [工程名称]  FROM [sheet1$A3:E] WHERE [姓名] IS NOT NULL AND [身份证号] IS NOT NULL ",代码出错。不知道是不是select无法直接抓取单元格的数据，请求帮助和指导。

附代码及文件：


Sub test()
    Dim fd As FileDialog
    Dim strFileName As String
    Dim conn As Object
    Dim rs As Object
    Dim strSQL As String
    Dim ws As Worksheet
    Dim i As Long

    ' 创建文件对话框
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Title = "请选择需要处理的Excel文件"
        .Filters.Clear
        .Filters.Add "Excel文件", "*.xls; *.xlsx"
        If .Show = -1 Then
            Application.ScreenUpdating = False
            For i = 1 To .SelectedItems.Count
                strFileName = .SelectedItems(i)
                ' 创建ADO连接
                Set conn = CreateObject("ADODB.Connection")
                conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
                ' 创建ADO记录集
                Set rs = CreateObject("ADODB.Recordset")
                strSQL = "SELECT [序号],[姓名],[身份证号] FROM [sheet1$A3:E] WHERE [姓名] IS NOT NULL AND [身份证号] IS NOT NULL "
                rs.Open strSQL, conn
                ' 将数据填入当前工作簿的指定工作表
                Set ws = ThisWorkbook.Worksheets("sheet1")
                ws.Cells(ws.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).CopyFromRecordset rs
                ' 关闭记录集和连接
                rs.Close
                conn.Close
            Next i
            Application.ScreenUpdating = True
        End If
    End With
End Sub





合并提取.zip (38.04 KB, 下载次数: 5)

2024-3-17 23:45 上传

点击文件名下载附件

LIUZHU

这是JS板块，发错了吧

fzxba

合并提取数据.zip (47.34 KB, 下载次数: 27)

2024-3-18 09:14 上传

点击文件名下载附件

windgod001

fzxba 发表于 2024-3-18 09:14

非常感谢，我还个小小的请求，能否在我原来代码基础上改，需要合并提取的文件要是能通过对话框选取就更完美，因为我是把这个表格作为一个工具表格，合并抓数据过来后我单独另存导出的。

windgod001

fzxba 发表于 2024-3-18 09:14

为什么要判断字典Dict中的元素数量是否等于49？
有点没看懂

fzxba

windgod001 发表于 2024-3-18 23:07
非常感谢，我还个小小的请求，能否在我原来代码基础上改，需要合并提取的文件要是能通过对话框选取就更完 ...

Sub test1() '论坛好像传不了附件，两种选择方式。
  
  Dim p As String
  
  With Application.FileDialog(msoFileDialogFolderPicker)   '选择文件夹
    .InitialFileName = ThisWorkbook.Path
    If .Show Then p = .SelectedItems(1) Else: Exit Sub
  End With
  If Right(p, 1) <> "\" Then p = p & "\"
  
  
  ActiveSheet.UsedRange.Offset(1).ClearContents
  
  Application.ScreenUpdating = False
  
  Dim ar, Conn As Object, Dict As Object
  Dim s As String, f As String
  Dim strConn As String, SQL As String, SQL_ As String
  
  Set Dict = CreateObject("Scripting.Dictionary")
  Set Conn = CreateObject("ADODB.Connection")
  
  s = "Excel 12.0;HDR=YES;Database="
  If Application.Version < 12 Then
    s = Replace(s, "12.0", "8.0")
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
  Else
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
  End If
  Conn.Open strConn & ThisWorkbook.FullName
  
  'p = ThisWorkbook.Path & "\"
  f = Dir(p & "*.xls?")
  SQL = "SELECT 序号,姓名,身份证号,'[.Name]' AS 工程名称,'[.Date]' AS 时间 FROM [" & s & p & "[.File]].[$A3:E] WHERE 身份证号 IS NOT NULL"
  SQL_ = "SELECT * FROM [" & Replace(s, "YES", "NO") & p & "[.File]].[$A1:A2]"
  Do
    If p & f <> ThisWorkbook.FullName Then
      ar = Conn.Execute(Replace(SQL_, "[.File]", f)).GetRows
      ar(0, 0) = Split(ar(0, 0), "工资信息")(0)
      'ar(0, 1) = Split(ar(0, 1), "：")(1)
      Dict.Add Replace(Replace(Replace(SQL, "[.File]", f), "[.Name]", ar(0, 1)), "[.Date]", ar(0, 0)), vbNullString
      If Dict.Count = 49 Then                  '一次最多能联合查询49个工作表 当工作簿很多时超作用
        Cells(Rows.Count, "A").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
        Dict.RemoveAll
      End If
    End If
    f = Dir
  Loop While Len(f)
  
  If Dict.Count Then
    Cells(Rows.Count, "A").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    Dict.RemoveAll
  End If
  
  Conn.Close
  Set Conn = Nothing
  Set Dict = Nothing
  
  Application.ScreenUpdating = True
  Beep
End Sub

Sub test2()
  
  Dim Fls As FileDialogSelectedItems
  
  With Application.FileDialog(msoFileDialogFilePicker) '多选文件
    .InitialFileName = ThisWorkbook.Path
    With .Filters
      .Clear
      .Add "Excel Files", "*.xls?"
    End With
    .AllowMultiSelect = True
    If .Show Then Set Fls = .SelectedItems Else Exit Sub
  End With
  
  ActiveSheet.UsedRange.Offset(1).ClearContents
  Application.ScreenUpdating = False
  
  Dim ar, Conn As Object, Dict As Object, f
  Dim strConn As String, SQL As String, SQL_ As String, s As String
  
  Set Dict = CreateObject("Scripting.Dictionary")
  Set Conn = CreateObject("ADODB.Connection")
  
  s = "Excel 12.0;HDR=YES;Database="
  If Application.Version < 12 Then
    s = Replace(s, "12.0", "8.0")
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
  Else
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
  End If
  Conn.Open strConn & ThisWorkbook.FullName
  
  SQL = "SELECT 序号,姓名,身份证号,'[.Name]' AS 工程名称,'[.Date]' AS 时间 FROM [" & s & "[.File]].[$A3:E] WHERE 身份证号 IS NOT NULL"
  SQL_ = "SELECT * FROM [" & Replace(s, "YES", "NO") & "[.File]].[$A1:A2]"
  
  For Each f In Fls
    If f <> ThisWorkbook.FullName Then
      ar = Conn.Execute(Replace(SQL_, "[.File]", f)).GetRows
      ar(0, 0) = Split(ar(0, 0), "工资信息")(0)
      'ar(0, 1) = Split(ar(0, 1), "：")(1)
      Dict.Add Replace(Replace(Replace(SQL, "[.File]", f), "[.Name]", ar(0, 1)), "[.Date]", ar(0, 0)), vbNullString
      If Dict.Count = 49 Then                  '一次最多能联合查询49个工作表 当工作簿很多时超作用
        Cells(Rows.Count, "A").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
        Dict.RemoveAll
      End If
    End If
  Next
  
  If Dict.Count Then
    Cells(Rows.Count, "A").End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
    Dict.RemoveAll
  End If
  
  Conn.Close
  Set Conn = Nothing
  Set Dict = Nothing
  
  Application.ScreenUpdating = True
  Beep
End Sub