Board logo

標題: (發問)WEB查詢,如何取消跳出的警告視窗 [打印本頁]

作者: jewayy    時間: 2011-10-31 00:02     標題: (發問)WEB查詢,如何取消跳出的警告視窗

各位先進,小弟有使用WEB查詢網頁資料,但常常會因為網路連線不良,出現以下訊息:

"此WEB查詢沒有傳回資料,要修改查詢,按[確定],按資料編輯列上的名稱方塊中的外部資料範圍,然後按[外部資料]工具列上的[編輯查詢]。"

必須將這訊息點掉,才能繼續更新WEB查詢的資料,常常程式跑一半卡住,非常困擾。
有試過Application.DisplayAlerts = False 或 Application.EnableEvents = false或On error resume  next
不過都沒有用,請各位先進指點一下,感激不盡。
作者: luhpro    時間: 2011-10-31 23:18

回復 1# jewayy
你可以於錯誤發生時將程式導向錯誤處理程序,
於 錯誤處理程序 開頭事先先加上中斷,
再於其中顯示出錯誤代碼,
最後將該代碼的處理程序加入即可.
  Sub Test()  
  On Error GoTo ErrorFix
  exit Sub

ErrorFix:
  MsgBox Err.Number
  MsgBox Err.Description
If Err.Number = 11 Then
.
.
    Err.Clear
  End If
  Resume
End Sub
作者: jewayy    時間: 2011-11-1 00:37

謝謝您的回覆。
不過就是程式抓不到Error,否則用On Error Resume  Next就有用了。
因此有嘗試過您的方法,就是跳不到ErrorFix,因此就沒辦法用Err.Number來處理了。
所以此錯誤"此WEB查詢沒有傳回資料,要修改查詢,按[確定],按資料編輯列上的名稱方塊中的外部資料範圍,然後按[外部資料]工具列上的[編輯查詢]。"還是繼續產生,無法消除。
請問還有其他idea嗎?還是非常謝謝您撥冗回覆~~
作者: GBKEE    時間: 2011-11-1 08:27

本帖最後由 GBKEE 於 2011-11-1 12:59 編輯

回復 3# jewayy
試試看
  1. Sub Ex()
  2. Dim t As Date
  3.     t = Time
  4.     On Error Resume Next
  5. 1:
  6.     Sheet1.QueryTables(1).Refresh False
  7.     Debug.Print Err.Number                 '即時運算視窗查看 Err.Number
  8.     If Err.Number > 0 Then                 'Web查詢 失敗
  9.         If Time > t + #12:00:10 AM# Then   '連線時間超過1分鐘
  10.             If MsgBox("連線時間超過1分鐘 繼續Web查詢 ??", vbYesNo) = vbNo Then Exit Sub
  11.             t = Time
  12.         End If
  13.         GoTo 1
  14.     End If
  15. End Sub
複製代碼
  1. Sub Ex1()
  2.     Dim t As Date
  3.     t = Time
  4.     On Error Resume Next
  5.     Do
  6.         Err.Clear
  7.         Sheet1.QueryTables(1).Refresh False
  8.         If Err.Number > 0 Then                 'Web查詢 失敗
  9.             If Time > t + #12:00:10 AM# Then   '連線時間超過1分鐘
  10.                 If MsgBox("連線時間超過1分鐘 繼續Web查詢 ??", vbYesNo) = vbNo Then Exit Sub
  11.                 t = Time
  12.             End If
  13.         End If
  14.     Loop While Err.Number > 0
  15. End Sub
複製代碼

作者: jewayy    時間: 2011-11-15 23:43

謝謝您的回覆,已經試了您的寫法,還是沒有辦法抓到錯誤視窗的事件來處理。
附上檔案好了。
Sheet2的資料會隨著Sheet1的A1~A3來做WEB查詢變動,因此設計C1~C3 copy過去改變A1~A3時進行WEB查詢。
C2的數值70645291是故意設計查詢不到的,想藉此練習碰到警告視窗要如何處理,請先進指點一下,感謝~

[attach]8554[/attach]

    Sub Ex2()
        Dim t As Date
        t = Time
        On Error Resume Next
        
    Worksheets("Sheet1").Activate
    Range("A1:A3").Value = Range("C1:C3").Value
        
        Do
            Err.Clear
            Sheet1.QueryTables(1).Refresh False
            If Err.Number > 0 Then                 'Web查詢 失敗
                GoTo J:
            End If
        Loop While Err.Number > 0

J:

    MsgBox "Game over"
   
    End Sub
作者: GBKEE    時間: 2011-11-16 07:38

回復 5# jewayy
  1. Sub Ex1()
  2.     Dim t As Date
  3.     t = Time
  4.     On Error Resume Next
  5.     With Sheet1
  6.         .Range("A1:A3").Value = .Range("C1:C3").Value
  7.     End With
  8.     With Sheet2
  9.         .Cells.Interior.ColorIndex = xlNone
  10.         For I = 1 To .QueryTables.Count
  11.             Err.Clear
  12.             .QueryTables(I).Refresh False
  13.             If Err.Number > 0 Then                 'Web查詢 失敗
  14.                 With .QueryTables(I).ResultRange
  15.                     .Interior.ColorIndex = 37
  16.                     .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count) = "查無資料"
  17.                 End With
  18.             End If
  19.         Next I
  20.     End With
  21. End Sub
複製代碼

作者: jewayy    時間: 2011-11-16 21:29

謝謝先進GBKEE版主指點迷津,現在才知道Querytables的用法,真的很受用。
不過,還是會跳出
"此WEB查詢沒有傳回資料,要修改查詢,按[確定]......."等的訊息
必須將這訊息點掉,才能繼續更新WEB查詢的資料,常常程式跑一半卡住,非常困擾。
再次斗膽請教,有方法讓這訊息不要跳出來嗎?
作者: GBKEE    時間: 2011-11-17 07:55

本帖最後由 GBKEE 於 2011-11-17 08:05 編輯

回復 7# jewayy
奇怪 測試沒問題的, 怎又出現 ,請改用物件類別模組.
請在 VAB中插入一 物件類別模組  會自動名為 Class1
執行 Ex
Module1的程式碼
  1. Sub Ex()
  2.     Dim i As Integer, Test() As New Class1
  3.     'Test指定為 新物件類別模組 :  Class1物件
  4.     On Error Resume Next
  5.     For i = 1 To Sheet2.QueryTables.Count
  6.         ReDim Preserve Test(1 To i)
  7.         Set Test(i).Query = Sheet2.QueryTables(i)
  8.         Test(i).Query.Refresh False
  9.     Next
  10. End Sub
複製代碼
物件類別模組   : Class1 的程式碼
  1. Option Explicit
  2. Public WithEvents Query As QueryTable    'Query指定為QueryTable物件
  3. Private Sub Query_AfterRefresh(ByVal Success As Boolean)   '查詢後的事件
  4.   If Success = False Then    '查詢失敗   'Success = True   查詢成功
  5.         With Query.ResultRange
  6.             .Interior.ColorIndex = 37
  7.             .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count) = "查無資料"
  8.         End With
  9.   End If
  10. End Sub
  11. Private Sub Query_BeforeRefresh(Cancel As Boolean)  '查詢前的事件
  12.     With Query.ResultRange
  13.             .Interior.ColorIndex = xlNone
  14.     End With
  15. End Sub
複製代碼

作者: jewayy    時間: 2011-11-17 16:45

謝謝您用心指導,在Module1執行Ex.
不知道我這樣寫對不對,請幫我確認,因為警告訊息還是會跑出來,哈哈。
附上檔案供您參考~[attach]8568[/attach]

模組Module1
    Sub Ex()
        Dim i As Integer, Test() As New Class1
        'Test指定為 新物件類別模組 :  Class1物件
        On Error Resume Next
        
        With Sheet1
            .Range("A1:A3").Value = .Range("C1:C3").Value
        End With
   
        For i = 1 To Sheet2.QueryTables.Count
            ReDim Preserve Test(1 To i)
            Set Test(i).Query = Sheet2.QueryTables(i)
            Test(i).Query.Refresh False
        Next
    End Sub

物件類別模式 Class1
   Option Explicit
    Public WithEvents Query As QueryTable    'Query指定為QueryTable物件
    Private Sub Query_AfterRefresh(ByVal Success As Boolean)   '查詢後的事件
      
      If Success = False Then    '查詢失敗   'Success = True   查詢成功
            With Query.ResultRange
                .Interior.ColorIndex = 37
                .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count) = "查無資料"
            End With
      End If
    End Sub
   
    Private Sub Query_BeforeRefresh(Cancel As Boolean)  '查詢前的事件
        With Query.ResultRange
                .Interior.ColorIndex = xlNone
        End With
    End Sub
作者: GBKEE    時間: 2011-11-17 17:37

回復 9# jewayy
沒辦法解決    你的 Web查詢 設定參數 變動   系統  自動更新資料    VBA無法控制   
   
  1. With Sheet1
  2.             .Range("A1:A3").Value = .Range("C1:C3").Value    '啟動 系統  自動更新資料
  3.         End With
複製代碼

作者: blue2263    時間: 2014-2-22 09:39

本帖最後由 blue2263 於 2014-2-22 09:42 編輯

請教G大我的也有相同問題?可否幫我看一下,也會出現,web查詢沒有傳回資料訊息
程式碼停止,出現訊息的代號在A1499(儲存格),我測試發現一個奇怪的現象.如果把下列程式碼位置,設在A1456會出現錯誤訊息
把位置設在A1497,狀態就正常,錯誤訊息就不會跳出
請教不知有何方法,可解決這問題?[attach]17567[/attach]

程式碼同下.........
Sub 資料下載整合()
    '資料網路下載->匯總Sheets
    Dim Rng As Range, Ar(1 To 3)
    Set Rng = Sheets("代碼").[a1456] '代碼起始位置在a2
    Do While Rng <> ""   '無代碼 中斷

        With Sheets("原始表")
             .Range("a6") = Rng
             On Error GoTo 101 '   'web 查無 到下一個代碼
             .Range("az7").QueryTable.Refresh BackgroundQuery:=False
            With .Range("BB12:BB27")
                    Ar(1) = Application.Transpose(.Cells)         '人數
                    Ar(2) = Application.Transpose(.Offset(, 1))   '股數
                    Ar(3) = Application.Transpose(.Offset(, 2))   '佔集保庫存數比例 (%)
            End With
        End With
        With Sheets("匯總").Range("A1").End(xlDown).Offset(1) '選擇工作表,到最底行
             .Cells(1) = Rng
             .Cells(1, 2) = Rng.Offset(, 1)
             .Cells(1, "C").Resize(, UBound(Ar(1))) = Ar(1)
             .Cells(1, "S").Resize(, UBound(Ar(1))) = Ar(2)
             .Cells(1, "AI").Resize(, UBound(Ar(1))) = Ar(3)
             .Cells(1, "AX") = ""
            '.Range("A1:aw1").Value = Sheets("原始表").Range("A6:aw6").Value

         End With
101
         Set Rng = Rng.Offset(1)   '下一個代碼
    Loop
End Sub
作者: joey0415    時間: 2014-2-23 12:23

回復 11# blue2263
股權分散的網頁,查不到資料會跳出視窗

win7會有些問題

我用是用xmlhttp下載來看的,只要網頁在本地端,就不會有連線問題

即使是彈跳視窗,在網頁中,查一下html body 就有相關的字句,自然可以跳過,如果不這樣用,也可以下載後用查檢網頁大小就知道有資料與查無資料的網頁大小是不一樣的

以上
作者: blue2263    時間: 2014-2-24 23:36

本帖最後由 blue2263 於 2014-2-24 23:47 編輯

謝謝j大解答
我將程式碼改為,On Error Resume Next
然後加一IF判斷,判斷資料無更改,就跳開,測試
看起來是沒問題,錯誤訊息不會跑出,且跳出,
我是新手,不知我這樣改,會不會有什麼問題?
還請指教謝謝!!

程式碼如下

Sub 資料下載整合()
    '資料網路下載->匯總Sheets
       Dim Rng As Range, Ar(1 To 3)
       Dim err
    Set Rng = Sheets("代碼").[a2] '代碼起始位置在a2
    Do While Rng <> ""   '無代碼 中斷
       Dim myErrNum As Long

        With Sheets("原始表")
             .Range("a6") = Rng
             On Error Resume Next   '發生錯誤陳述式之後的陳述式繼續執行
             err = Sheets("原始表").Range("az7")
             .Range("az7").QueryTable.Refresh BackgroundQuery:=False
             On Error GoTo 0    '停止error resume
            If err = Sheets("原始表").Range("az7") Then GoTo 103
            With .Range("BB12:BB27")
                    Ar(1) = Application.Transpose(.Cells)         '人數
                    Ar(2) = Application.Transpose(.Offset(, 1))   '股數
                    Ar(3) = Application.Transpose(.Offset(, 2))   '佔集保庫存數比例 (%)
            End With
        End With
        With Sheets("匯總").Range("A1").End(xlDown).Offset(1) '選擇工作表,到最底行
             .Cells(1) = Rng
             .Cells(1, 2) = Rng.Offset(, 1)
             .Cells(1, "C").Resize(, UBound(Ar(1))) = Ar(1)
             .Cells(1, "S").Resize(, UBound(Ar(1))) = Ar(2)
             .Cells(1, "AI").Resize(, UBound(Ar(1))) = Ar(3)
             .Cells(1, "AX") = ""
            '.Range("A1:aw1").Value = Sheets("原始表").Range("A6:aw6").Value
         End With
103
         Set Rng = Rng.Offset(1)   '下一個代碼
         
    Loop
End Sub
作者: GBKEE    時間: 2014-2-25 16:50

回復 13# blue2263
以下是我的見解
  1.    On Error GoTo 101 '   'web 查無 到下一個代碼  
  2. ** 單一次的Refresh失敗 On Error GoTo 101 可以處理
  3. ** 但連續的Refresh失敗 On Error GoTo 101 無法處理(無解)
  4.              .Range("az7").QueryTable.Refresh BackgroundQuery:=False
  5. QueryTable.Refresh BackgroundQuery:=False           
複製代碼

作者: blue2263    時間: 2014-2-26 05:29

感謝g大解答
原來連續的refresh失敗無法處理,難怪上次更改代碼開始位置,會一下正常,一下不正常
作者: 7777    時間: 2018-8-9 15:42

回復 4# GBKEE


請教~GBKEE大大
我也有相同情形?可否幫忙協助一下

跳出 警示"視窗"
如何 自動關閉視窗,不影響下且 繼續巨集作業~~

巨集作業 是
某個網頁 每15秒更新一次
ActiveWorkbook.RefreshAll

有時會跳出視窗 "無法開啟  ........." 之視窗
可以加什麼
將 視窗
自動關閉視窗,不影響下且 繼續巨集作業~~

導入 4# 的內容,不勝了解
還請 大大 指點一下,感謝~

[attach]29186[/attach]

Sub 偵測()

On Error Resume Next
        Application.OnTime Now + TimeValue("00:00:15"), "偵測"
        ActiveWorkbook.RefreshAll

        'http://info512.taifex.com.tw/Future/VIXQuote_Norl.aspx
        '自動關閉視窗,不影響下且 繼續巨集作業~~


End Sub

還請 大大 指點一下,感謝~
作者: faye59    時間: 2018-8-9 21:07

回復 16# 7777


    試試看吧!
  1. Sub test()
  2.     Dim x
  3.     Dim oie As Object: Set oie = CreateObject("internetexplorer.application")
  4.     With oie
  5.         .Visible = True
  6.         .Navigate ""
  7.         Do While .readystate <> 4 Or .busy: DoEvents: Loop
  8. Set wshshell = CreateObject("wscript.shell")

  9. Do
  10.     ret = wshshell.AppActivate("Microsoft Excel")
  11. Loop Until ret = True

  12.     Application.Wait Now + 2 / 86400
  13.     ret = wshshell.AppActivate("Microsoft Excel")
  14.         If ret = True Then
  15.                    ret = wshshell.AppActivate("Microsoft Excel")
  16.                 Application.Wait Now + 2 / 86400
  17.                 wshshell.SendKeys "{enter}"
  18.         End If
  19.         Application.Wait Now + 2 / 86400
  20.         Do While .readystate <> 4 Or .busy: DoEvents: Loop
  21.         .Quit
  22.     End With
  23. End Sub
複製代碼

作者: 7777    時間: 2018-8-14 16:11

回復 17# faye59

faye59大大  感謝你 撥冗協助
<<試試看吧!>> 好像很簡單
不懂下,不敢隨便發問,
就還是先..爬了爬文,試了試 (2天)...... 還是不懂

我該 如何.... 溶入原先的  Sub 偵測() 內

Sub test()
    Dim x   
    Dim oie As Object: Set oie = CreateObject("internetexplorer.application")
    With oie
        .Visible = True   '我 要改 False 不顯示 表現
        .Navigate ""       ' 這是 要放網址嗎??  如有 3個 網址...的話  該???
        Do While .readystate <> 4 Or .busy: DoEvents: Loop
Set wshshell = CreateObject("wscript.shell")

Do
    ret = wshshell.AppActivate("Microsoft Excel")
Loop Until ret = True

    Application.Wait Now + 2 / 86400    '等待 2秒
    ret = wshshell.AppActivate("Microsoft Excel")
        If ret = True Then
                   ret = wshshell.AppActivate("Microsoft Excel")
                Application.Wait Now + 2 / 86400
                wshshell.SendKeys "{enter}"
        End If
        Application.Wait Now + 2 / 86400
        Do While .readystate <> 4 Or .busy: DoEvents: Loop
        .Quit
    End With
End Sub

請  faye59大大 幫忙  感謝!
作者: faye59    時間: 2018-8-16 21:10

回復 18# 7777


    網址3個的話要看你讀取順序,猜你應該都是分批讀取吧,只要在網址地方改成字串再用迴圈方式重複這段程序即可,
或是你可以附上你的最新進度檔案,這樣比較清楚你的問題點。
其實這段程序只是讓你測試用,從第7列開始才是重點。
  1. Sub test()
  2.     Dim oie As Object: Set oie = CreateObject("internetexplorer.application")
  3.     With oie
  4.         '.Visible = True '這部分註解掉也沒關係,註解掉不會顯示背景還是會執行跟False一樣,因為測試所以需開啟畫面確認後續程序無誤
  5.         .Navigate "" '輸入網址
  6.         Do While .readystate <> 4 Or .busy: DoEvents: Loop
  7. Set wshshell = CreateObject("wscript.shell") '引用其它物件,呼叫其它應用程式

  8. Do '迴圈應用程式中指定物件
  9.     ret = wshshell.AppActivate("Microsoft Excel") '找尋引用物件名稱,如果跳出視窗標題是"網頁訊息"修改成警告訊息標題
  10.     '陳述式AppActivate標題 [等待]
  11. Loop Until ret = True '當ret有值時結束迴圈

  12.     Application.Wait Now + 2 / 86400 '這部分其實可以不等待
  13.     ret = wshshell.AppActivate("Microsoft Excel")
  14.         If ret = True Then
  15.                    ret = wshshell.AppActivate("Microsoft Excel")
  16.                 Application.Wait Now + 2 / 86400 '這裡一定要等待2秒,其實時間不一定,只是SendKeys這個動作常常發生不穩定性問題,確保程序沒問題才執行enter這動作
  17.                 wshshell.SendKeys "{enter}" '對警告訊息視窗按下鍵盤enter按鍵
  18.         End If
  19.         Application.Wait Now + 2 / 86400 '等待2秒
  20.         Do While .readystate <> 4 Or .busy: DoEvents: Loop '確認網頁載入完成
  21.         .Quit '關閉網頁
  22.     End With
  23. End Sub
複製代碼
以上是我以前從麻辣家族某個地方Copy過來的(忘記來源了...抱歉),我實際用上是針對會跳出警告視窗地方加入以下程序即可。
  1. Set Wshshell = CreateObject("wscript.shell")'新增Wshshell為呼叫其它應用程式物件
  2. Application.Wait Now + 2 / 86400'等待2秒
  3. ret = Wshshell.AppActivate("網頁訊息")'ret應用程式中是否有"網頁訊息"Title
  4. If ret = True Then'確認有執行
  5. Wshshell.SendKeys "{enter}"'鍵盤操作enter指令
  6. End If
複製代碼

作者: 7777    時間: 2018-8-20 20:53

回復 19# faye59

感謝
faye59大大
這麼細心的解答指導...
讓我學習不少,解惑問題
謝謝!!
   
小弟 有附檔...  [attach]29244[/attach]
再請教
感謝




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)