用VBA跨表提数据，跪求大神！在线等！急~

菜鸟呆瓜求带

求大神！帮我解决下这个提数据宏程序。现在有两个excel表，一个是“提数据”、一个是“资源”。需要把“资源”里首页和至尾页中间的所有sheet页内容提取到“提数据”表的内容sheet页中，对应字段的内容需要匹配上。想哭、、、跪求大神帮忙啊。

lsc900707

不难实现，需要时间而已。

魂断蓝桥

Option Explicit

Sub a()
        Dim cnn As Object
        Dim rs As Object
        Dim n%, s$, arr(1 To 999), i%, SQL$, BRR
        Set cnn = CreateObject("ADODB.CONNECTION")
        Set rs = CreateObject("adodb.Recordset")
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.Path & "\资源.xls"
        Set rs = cnn.OpenSchema(20)
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                s = rs("TABLE_NAME").Value
                If s Like "*$*" Then
                    If Not s Like "*页*" Then
                        n = n + 1
                        arr(n) = Mid(s, 2, Len(s) - 2)
                    End If
                End If
            End If
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
        cnn.Close
        [A5:R17] = ""
        cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & ThisWorkbook.Path & "\资源.xls"
        For i = 1 To n
            SQL = "select * from [" & arr(i) & "B30:B30]"
            [C4].Offset(i, 0) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "H33:H33]"
            [C4].Offset(i, -2) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "B33:B33]"
            [C4].Offset(i, -1) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "D35:D43] UNION ALL select * from [" & arr(i) & "I35:I36] "
            BRR = cnn.Execute(SQL).GETROWS
             [C4].Offset(i, 1).Resize(1, 11) = BRR
             SQL = "select * from [" & arr(i) & "F46:F48]"
             BRR = cnn.Execute(SQL).GETROWS
            [C4].Offset(i, 12).Resize(1, 3) = BRR
        Next
    cnn.Close
    Set cnn = Nothing
    End Sub

菜鸟呆瓜求带

魂断蓝桥 发表于 2018-4-2 13:59
Option Explicit

Sub a()

太厉害了，大神。万分感谢。~~还差一个备注字段，没有匹配上。

魂断蓝桥

菜鸟呆瓜求带 发表于 2018-4-2 15:28
太厉害了，大神。万分感谢。~~还差一个备注字段，没有匹配上。

Option Explicit

Sub a()
        Dim cnn As Object
        Dim rs As Object
        Dim n%, s$, arr(1 To 999), i%, SQL$, BRR
        Set cnn = CreateObject("ADODB.CONNECTION")
        Set rs = CreateObject("adodb.Recordset")
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.Path & "\资源.xls"
        Set rs = cnn.OpenSchema(20)
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                s = rs("TABLE_NAME").Value
                If s Like "*$*" Then
                    If Not s Like "*页*" Then
                        n = n + 1
                        arr(n) = Mid(s, 2, Len(s) - 2)
                    End If
                End If
            End If
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
        cnn.Close
        [A5:R17] = ""
        cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=NO'; Data Source=" & ThisWorkbook.Path & "\资源.xls"
        For i = 1 To n
            SQL = "select * from [" & arr(i) & "B30:B30]"
            [C4].Offset(i, 0) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "H33:H33]"
            [C4].Offset(i, -2) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "B33:B33]"
            [C4].Offset(i, -1) = cnn.Execute(SQL)(0)
            SQL = "select * from [" & arr(i) & "D35:D43] UNION ALL select * from [" & arr(i) & "I35:I36] "
            BRR = cnn.Execute(SQL).GETROWS
             [C4].Offset(i, 1).Resize(1, 11) = BRR
             SQL = "select * from [" & arr(i) & "F46:F48]"
             BRR = cnn.Execute(SQL).GETROWS
            [C4].Offset(i, 12).Resize(1, 3) = BRR
            SQL = "select * from [" & arr(i) & "d49:d49]"
             [C4].Offset(i, 15) = cnn.Execute(SQL)(0)
        Next
    cnn.Close
    Set cnn = Nothing
    End Sub

lgfromch

Sub test()

Dim mypath$, mywb$, wb As Object, sht As Worksheet, arr(1 To 18, 1 To 3), i&, n&, sj$

mypath = ThisWorkbook.Path & "\"
mywb = mypath & "资源.xls"
Set wb = GetObject(mywb)

For Each sht In wb.Sheets
    If sht.Name <> "首页" And sht.Name <> "尾页" Then
        With sht
            arr(1, i) = .[H33]
            arr(2, i) = .[B33]
            arr(3, i) = .[B30]
            arr(13, i) = .[I35]
            arr(14, i) = .[I36]
            arr(15, i) = .[F46]
            arr(16, i) = .[F47]
            arr(17, i) = .[F48]
            arr(18, i) = .[D49]
            For n = 4 To 12
                arr(n, i) = .Cells(31 + n, 4)
            Next n
        End With
    End If
    i = i + 1
Next
ThisWorkbook.Sheets("内容").Range("A5:R7") = WorksheetFunction.Transpose(arr)

   
End Sub

lsc900707

附件供测试参考：

boy8199

数据多超过65336，别用ADO，太坑了。

Askinofblue

Sub 从外部Excel取数()
Debug.Print s.getcell(s.exceltoqax(ThisWorkbook.Path & "\资源.xls", "1$A29:A30"), 0, 0)
End Sub

用sqlcel函数只需要这一句就可以取出资源表名为1的sheet的A30单元格的值，具体可查sqlcelfuncs
https://sqlcel.com/sqlcelfuncs/

mp3_2004

lsc900707 发表于 2018-4-2 17:28
附件供测试参考：

版主老师好，这个函数用了很多年都可以，最近突然不行了，只能当前表内用，公式在另外一个sheet就替换不到值，不知道是什么原因啊？

Function fml(cel As Range)
Application.Volatile
ShName = cel.Parent.Name
fmltext = Replace(cel.Formula, "$", "")
fmltext = Replace(fmltext, "=", "")
Set regExp = CreateObject("VBScript.RegExp")
regExp.Pattern = "[A-Z]{1,2}\d{1,}"
regExp.Global = True
     
For Each i In regExp.Execute(fmltext)
fmltext = Replace(fmltext, i, Worksheets(ShName).Range(i).Text)
Next

fml = fmltext
End Function