跑到一半會卡住~~ - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 跑到一半會卡住~~

返回列表下一主題上一主題發帖

[發問] 跑到一半會卡住~~

小學生 Rank: 1

帖子: 7
主題: 2
精華: 0
積分: 12
點名: 0
作業系統: WIN7
軟體版本: WIN7
閱讀權限: 10
註冊時間: 2016-9-28
最後登錄: 2017-3-5

論壇贊助勳章

6^# 跳轉到 »

發表於 2016-12-3 12:16 | 只看該作者

GBKEE 您好!
就像下方畫面，跑了100多筆之後就一直卡在這個畫面。

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

5^#

發表於 2016-12-3 11:23 | 只看該作者

本帖最後由准提部林於 2016-12-3 11:26 編輯

Sub ROE_1()
[ROE總表!B1].Value = String(52, "+")
For i = 10 To [個股資料!B281].End(xlDown).Row
With Sheets("ROE").QueryTables.Add(Connection:= _
"URL;http://stockchannelnew.sinotrade.com.tw/z/zc/zcr/zcra/zcra_" & _
[個股資料!B1].Cells(i, 1) & ".djhtm", Destination:=[ROE!B1])
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
Dim xF As Range, xE As Range
Set xF = [ROE!C1:C500].Find("股東權益報酬率")
If Not xF Is Nothing Then
Set xE = [ROE總表!B1].End(xlDown)(2)
xE.Select
Range(xF, xF.End(xlToRight)).Copy xE
xE(1, 0) = Sheets("個股資料").Range("C" & i)
End If
Sheets("ROE").UsedRange.Clear
Next
End Sub

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2016-12-3 09:44 | 只看該作者

回復 3# power82843

卡在那裡?

For i = 10 To Sheets("個股資料").Range("B281").End(xlDown).Row
Worksheets("ROE總表").Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
Worksheets("ROE總表").Range("B2:J2") = Array("期別", "104", "103", "102", "101", "100", "99", "98", "97")
'是少了這裡嗎?

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

小學生 Rank: 1

帖子: 7
主題: 2
精華: 0
積分: 12
點名: 0
作業系統: WIN7
軟體版本: WIN7
閱讀權限: 10
註冊時間: 2016-9-28
最後登錄: 2017-3-5

論壇贊助勳章

3^#

發表於 2016-12-2 08:28 | 只看該作者

GBKEE 大大抱歉沒有說清楚，是下面這一段程式，一開始可以跑得蠻順的，可是跑個80~200筆後就會卡住不跑，指標呈現等待的圖案。

Sub ROE()
For i = 10 To Sheets("個股資料").Range("B281").End(xlDown).Row
Worksheets("ROE總表").Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
Worksheets("ROE").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://stockchannelnew.sinotrade.com.tw/z/zc/zcr/zcra/zcra_" & Sheets("個股資料").Range("B" & i) & ".djhtm", Destination:=Range("B1"))
.Name = "0000000"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("C1:C500").Find("股東權益報酬率").Select
Range(Selection, Selection.End(xlToRight)).Copy
Worksheets("ROE總表").Select
Worksheets("ROE總表").Range("B1").Select
ActiveCell.End(xlDown).Select
lastrow = ActiveCell.Row
ActiveSheet.Paste Destination:=Worksheets("ROE總表").Range("b" & lastrow + 1)
Worksheets("ROE總表").Range("A" & lastrow + 1).Value = Worksheets("個股資料").Range("C" & i).Value
Worksheets("ROE").Select
Worksheets("ROE").Range("B1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Delete
Next
End Sub

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2016-12-2 07:18 | 只看該作者

本帖最後由 GBKEE 於 2016-12-2 07:19 編輯

回復 1# power82843

是這裡卡住嗎?

Option Explicit
Sub 股利股息()
Dim Sh As Worksheet, i As Integer
On Error Resume Next '不理會程式上的錯誤,程式繼續執行下去
Set Sh = Sheets("股利股息") '沒有 Sheets("股利股息")時有程式上的錯誤]
On Error GoTo 0 '程式停止處理錯誤,程式執行上有錯誤發生會終止.
If Sh Is Nothing Then '沒有 Sheets("股利股息")時 Sh Is Nothing
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "股利股息"
Set Sh = Sheets("股利股息")
End If
With Sh ' Worksheets("股利股息").Select
.UsedRange.Clear
.Range("A1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
.Range("B1").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
.Range("B2").Value = "++++++++++++++++++++++++++++++++++++++++++++++++++++"
End With
For i = 10 To Sheets("個股資料").Range("B10").End(xlDown).Row
Sh.Cells(Rows.Count, 2).End(xlUp).Offset(1, -1).Resize(11) = Worksheets("個股資料").Range("C" & i).Value ' '將A欄位填入股票名稱，連續填寫11列
With Sh.QueryTables.Add(Connection:= _
"URL;https://tw.stock.yahoo.com/d/s/dividend_" & Sheets("個股資料").Range("B" & i) & ".html", Destination:=Sh.Cells(Rows.Count, 2).End(xlUp).Offset(1))
.Name = "0000000"

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

靜思自在 : 天上最美是星星，人生最美是溫情。

返回列表下一主題上一主題