帖子: 94
主題: 28
精華: 0
積分: 145
點名: 0
作業系統: windows
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2011-9-22
最後登錄: 2021-10-18

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2013-11-16 01:37 | 只看該作者

[發問] 下載中斷問題

大家好:

   想請問個問題，因為我下載會中斷，如圖所示。
   不知道有沒有辦法加個程式碼，可以直接判斷，而不造成下載過程有無法開啟的狀況。
   謝謝。

問題.jpg (14.98 KB)

問題.jpg

Desktop.rar (276.97 KB)

樓主熱帖

luhpro

高中生 Rank: 3 Rank: 3

帖子: 824
主題: 6
精華: 0
積分: 904
點名: 0
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2023-12-24

2^#

發表於 2013-11-16 09:30 | 只看該作者

本帖最後由 luhpro 於 2013-11-16 09:33 編輯

回復 1# spermbank
這種情形最常見的處理方式就是加上錯誤處理.

因為附檔在我的 Excel 2003 執行時會一直有錯誤,
所以我自己另外做了一個檔案,
你可以參照著修改你的程式.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i%, j&
Dim bErr As Boolean
On Error GoTo errGet
bErr = False
For i = 1 To 6
j = j + i
If i = 3 Then Err.Raise 1004 ' 此行模擬網頁讀取失敗,發生 1004 錯誤
If Not bErr Then
MsgBox "執行讀取網頁的動作, i = 3 時會模擬發生錯誤, 目前 i =" & i
Else
MsgBox "網頁讀取失敗後的處理,例 : 重讀, 等幾秒..., i = 3 時會模擬發生錯誤, 目前 i =" & i
bErr = False
End If
Next
On Error GoTo 0
Exit Sub
errGet:
If Err.Number = 1004 Then bErr = True
Resume Next
End Sub

複製代碼

Desktop-a.zip (7.26 KB)

TOP

spermbank

中學生 Rank: 2

帖子: 94
主題: 28
精華: 0
積分: 145
點名: 0
作業系統: windows
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2011-9-22
最後登錄: 2021-10-18

3^#

發表於 2013-11-16 21:39 | 只看該作者

回復 2# luhpro

您好:
   不知道如何加入您給我的程式碼，但是更新的時候會再.Refresh這一行出現錯誤。
可以再請多指教一些嗎? 謝謝。

Sub 下載基本資料()

Range("P" & 23).Formula = "更新開始..." '.改
Application.ScreenUpdating = False

Sheets("DDE").Select
x = Application.WorksheetFunction.CountA(Range("A:A")) '欄位有值範圍計算

With ThisWorkbook

For Each a In .Sheets("DDE").Range("A" & 1418, "A" & x - 1).SpecialCells(xlCellTypeConstants).Offset(1) '設定範圍  '==========要減1============

更新資料 a '執行12檔案更新

Workbooks("風險評估.xlsx").Sheets(Array("IS", "ISQ", "BS", "BSQ", "BASIC", "YrPrice", "FR", "CFS", "ISQT")).Copy '複製工作表

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Base\" & CStr(a) & ".xlsx" '另存新檔

關檔

Next

End With

Sheets("DDE").Select
Range("P" & 23).Formula = "更新結束" '.改
Application.ScreenUpdating = True
End Sub

Sub 更新資料(a)

Dim Sh As Worksheet, MyURL$, MyQy As QueryTable

With ThisWorkbook

fd = .Path & "\基本面\風險評估\"

fs = Dir(fd & "*.xlsx")

Do Until fs = ""

With Workbooks.Open(fd & fs)

For Each Sh In .Sheets

      With Sh

      If .QueryTables.Count > 0 Then

         Set MyQy = .QueryTables(1)

         With .QueryTables(1)

         MyURL = .Connection

         If InStr(MyURL, "StockID") > 0 Then

            k = Val(Split(MyURL, "=")(UBound(Split(MyURL, "="))))

            Else

            k = Val(Split(MyURL, "_")(1))

         End If

         MyURL = Replace(MyURL, k, a)

         .Connection = MyURL '更改查詢

         .BackgroundQuery = False '幕前更新

         .Refresh '更新

         End With

      End If

      End With

Next

End With

fs = Dir()

Loop

End With

End Sub

Sub 關檔()

For Each w In Windows

If w.Caption <> ThisWorkbook.Name Then w.Close 1

Next

End Sub

TOP

luhpro

高中生 Rank: 3 Rank: 3

帖子: 824
主題: 6
精華: 0
積分: 904
點名: 0
作業系統: Win 10,7
軟體版本: 2019,2013,2003
閱讀權限: 50
性別: 男
註冊時間: 2010-5-3
最後登錄: 2023-12-24

4^#

發表於 2013-11-16 22:38 | 只看該作者

本帖最後由 luhpro 於 2013-11-16 22:50 編輯

回復 3# spermbank
以下程式放在 Module 內 :

Public bStop As Boolean

複製代碼

Sub 下載基本資料()
  .
  .
  .
更新資料 a '執行12檔案更新
If bStop Then Exit For
  .
  .
  .
End Sub

Sub 更新資料(a)
  Dim Sh As Worksheet, MyURL$, MyQy As QueryTable
  Dim iI%, lJ&, OpenForms
  .
  .
  .
  On Error GoTo errGet
            .Refresh '更新
  On Error GoTo 0
         End With
      End If
      End With
Next
End With
fs = Dir()
Loop
End With
  Exit Sub

: errGet
  If Err.Number = 1004 Then
For lJ = 1 To 5000 ' 讀取網頁失敗時, 等一段時間再重讀一次, 若連續5次失敗,則中止讀取.
   If lJ Mod 1000 = 0 Then OpenForms = DoEvents ' 每隔一段時間將控制權還給Windows處理其他程式的作業.
Next
iI = iI + 1
If iI > 10 Then
   bStop = True
   MsgBox "讀取網頁失敗, 程式終止..."
   Exit Sub
End If
Resume
  Else
Resume Next
  End If
End Sub

TOP

spermbank

中學生 Rank: 2

帖子: 94
主題: 28
精華: 0
積分: 145
點名: 0
作業系統: windows
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2011-9-22
最後登錄: 2021-10-18

5^#

發表於 2013-11-17 01:20 | 只看該作者

回復 4# luhpro

完全可以跑，不會有中斷現象，真是十分感謝^^

TOP