将Web查询数据导入到VBAvariables而不是Excel电子表格单元格中
我希望从我的Excel电子表格中执行networking查询。 但是我不想在工作表上显示数据。 我想将它直接存储到VBA数组中。
我在互联网上find这个例子返回SQL查询结果到VBAvariables而不是单元格
这是从ODBC连接的链接编码的解决scheme。 我想适应这个networking查询解决scheme。 不知道如何修改它。
Dim ws As Workspace, db As Database, rs As Recordset Dim sqlstr As String, ToolID As String Private Sub OpenODBC(ws As Workspace, db As Database, dsn As String, id As String, pwd As String) Dim dsnStr As String Set ws = CreateWorkspace("ODBCWorkspace", "", "", dbUseODBC) Workspaces.Append ws ws.LoginTimeout = 300 dsnStr = "ODBC;DSN=" & dsn & ";UID=" & uid & ";PWD=" & pwd Set db = ws.OpenConnection(dsn, dbDriverNoPrompt, False, dsnStr) db.QueryTimeout = 1800 End Sub Sub Tool() On Error Goto errhandler: Call OpenODBC(ws, db, "AC", "USERNAME", "PASSWORD") sqlstr = "SELECT FHOPEHS.LOT_ID, FHOPEHS.TOOL_ID" & Chr(13) & "" & Chr(10) & "FROM DB2.FHOPEHS FHOPEHS" & Chr(13) & "" & Chr(10) & "WHERE (FHOPEHS.LOT_ID='NPCC1450.6H') AND (FHOPEHS.TOOL_ID Like 'WPTMZ%')" Set rs = db.OpenRecordset(sqlstr, dbOpenSnapshot) ToolID = rs("TOOL_ID") Goto ending errhandler: If Err.Number = 1004 Then Goto ending End If ending: MsgBox ToolID End Sub 我没有外部链接共享，这是一个内部网，但下面是我的代码，我试图修改将结果存储在一个数组而不是工作表单元格 – 如下所示在我的代码目标是单元格工作表上的“A1”。
我发布的初始示例显示了如何直接将数据存储在variables“ Set rs = db.OpenRecordset（sqlstr，dbOpenSnapshot） ”中。
我在网上find的其他解决scheme，将数据存储到工作表上的位置，然后将其移动到数组中，完成删除工作表上内容的操作。 我不想做这个过程，我希望直接从查询结果中进入variables。
Sheets("Raw Data").Select Cells.Select Selection.ClearContents Selection.QueryTable.Delete With ActiveSheet.QueryTables.Add(Connection:= _ "URL;http://myInternalAddress/myServerSideApp.php", Destination:=Range("A1")) .Name = "AcctQry" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = True .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlEntirePage .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With
预期的结果将是一个名字和他们的首字母的名单
stream出数据的php代码看起来像这样
function getEngineers() { $sql = 'select `engname` as `name`, `engineer` as `initials` from `engineers`'; if ( $result = $db->query($sql) ) { if ($result->num_rows > 0) { ?> <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <html lang="en"> <head></head> <body> <table> <tbody> <?php while ($n = $result->fetch_array()) { echo '<tr><td>'.$n['name'].'</td><td>'.$n['initials'].'</td></tr>'; } ?> </tbody> </table> </body> </html> <?php }else{ throw new Exception('No names returned'); } }else{ throw new Exception("Query to get engineer's names failed"); } }
这是来自浏览器的输出。 基本上有两列，1.名字，2.首字母缩写
好的，这里是HTML代码的屏幕截图，没有什么特别的 
下面是一些示例，展示了如何自动化IE并从DOM中检索数据，并制作XHR和parsing响应。
testing样本如下：
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <html lang="en"> <head></head> <body> <table> <tbody> <tr><td>Miggs, Thomas </td><td>TJM</td></tr> <tr><td>Nevis, Scott </td><td>SRN</td></tr> <tr><td>Swartz, Jeff </td><td>JRS</td></tr> <tr><td>Manner, Jack </td><td>JTM</td></tr> <tr><td>Muskey, Timothy </td><td>TMM</td></tr> <tr><td>Koeller, Steven </td><td>SRK</td></tr> <tr><td>Masters, Jeff </td><td>JLM</td></tr> </tbody> </table> </body> </html>
我通过链接放置它以使其可用于debugging目的。
自动执行IE并从DOM中检索必要数据的代码：
Sub TestIE() Dim aRes As Variant Dim i As Long With CreateObject("InternetExplorer.Application") ' Make visible for debug .Visible = True ' Navigate to page .Navigate "https://googledrive.com/host/0BwJV6wOaXFzIZkZDRzVmX2ptNm8" ' Wait for IE ready Do While .ReadyState <> 4 Or .Busy DoEvents Loop ' Wait for document complete Do While .Document.ReadyState <> "complete" DoEvents Loop ' Wait for target table accessible Do While .Document.getElementsByTagName("table").Length = 0 DoEvents Loop ' Process target table With .Document.getElementsByTagName("table")(0) ' Create 2d array ReDim aRes(1 To .Rows.Length, 1 To 2) ' Process each table row For i = 1 To .Rows.Length With .Rows(i - 1).Cells ' Assign cells content to array elements aRes(i, 1) = .Item(0).innerText aRes(i, 2) = .Item(1).innerText End With Next End With .Quit End With End Sub
使用XHR请求并使用RegExparsing响应的代码：
Sub TestXHR() Dim sRespText As String Dim aRes As Variant Dim i As Long With CreateObject("MSXML2.ServerXMLHttp") .Open "GET", "https://f1aef461d18be47b73b6fa674791d9bc6ba6da82.googledrive.com/host/0BwJV6wOaXFzIZkZDRzVmX2ptNm8/", False .Send sRespText = .responseText End With With CreateObject("VBScript.RegExp") .Global = True .MultiLine = True .IgnoreCase = True .Pattern = "<tr><td>([\s\S]*?)</td><td>([\s\S]*?)</td></tr>" ' Get matches collection With .Execute(sRespText) ' Create 2d array ReDim aRes(1 To .Count, 1 To 2) ' Process each match For i = 1 To .Count ' Assign submatches content to array elements With .Item(i - 1) aRes(i, 1) = .SubMatches(0) aRes(i, 2) = .SubMatches(1) End With Next End With End With End Sub
这两种方法在最后一个换行点的aRes数组中都给出了相同的结果：
