(不定期更新)使用VBA解決 excel web 查詢無法匯入、匯入太慢的股市資料

yucheng1011 wrote:
我的電腦應該就是見鬼了,改用了
CreateObject("WinHttp.WinHttpRequest.5.1")
就可以部份運行了.之前就是卡在第一筆



XMLHttpRequest(就是物件開頭MSXML…那些)
會受電腦內的瀏覽器相關設定影響
反應速度比較快

WinHttp(就是物件開頭WinHttp…那些)
和瀏覽器相關設定無關,是獨立物件
速度略慢,但功能較多
平常xmlhttp、winhttp都可以混用沒問題…

您用MSXML不行
改用winhttp跳過瀏覽器相關設定,可以下載,但偶爾還是不正常
那就是說,其實問題是在您的windows系統,裝了什麼奇怪的東西、改了什麼奇怪的設定
3台電腦中只有一台出問題,你需要重灌的是windows,不是office

今天測試下載2千筆有效股票代碼x10次,全部都是html格式正常下載
把686樓的範例,多加上一個產生總表的功能



而這個總表,是參考(抄襲),投資理財區專家Acer_kewei,所整理的表
(參考來源)
https://www.mobile01.com/topicdetail.php?f=291&t=5107288&p=1284






因為是用現有的access資料庫
所以除了新增的總表整理用程式碼、多加了一個按鈕、多了一個工作表2之外,其它幾乎沒改
有變動的地方如下


'typesetting副程式,修正一行
sub TypeSetting()
……
……
Call SetFormatCondition(Sheets("工作表1").Range("m4:n20"))
……
……
end sub

'SetFormatCondition副程式,改了幾行
Sub SetFormatCondition(Crange As Range)

Dim C1 As FormatCondition, C2 As FormatCondition

Crange.FormatConditions.Delete
Crange.Font.Bold = True
Set C1 = Crange.FormatConditions.Add(xlCellValue, xlGreater, "=0")
C1.Font.Color = vbRed
Set C2 = Crange.FormatConditions.Add(xlCellValue, xlLess, "=0")
C2.Font.Color = -11489280

End Sub


'================================================
'以下是這次的主要更新,整理總表用的副程式
'================================================

Sub ListAllStock()

Dim i As Integer

'====for debug ======
'Target = ThisWorkbook.Path & "\" & "stock.accdb"
'====================

Sheets("工作表2").Cells.Clear

Call AddComboData(Sheets("常用股票").Range("a1").CurrentRegion.Rows.Count, 1)

For i = 1 To Sheets("工作表1").Shapes("combo_0").ControlFormat.ListCount

Stockid = Sheets("工作表1").Shapes("combo_0").ControlFormat.List(i)
Use_Combo_Changeid = True
Call Manually

Sheets("工作表2").Range("c2:d17").Offset(0, (i - 1) * 2).Value = Sheets("工作表1").Range("m3:n18").Value
Sheets("工作表2").Range("d19").Offset(0, (i - 1) * 2).Value = Sheets("工作表1").Cells(Sheets("工作表1").Range("j65000").End(xlUp).Row, 10).Value
Sheets("工作表2").Cells(1, (i - 1) * 2 + 3).Value = Split(Stockname, "證券名稱:")(1)
Sheets("工作表2").Cells(1, (i - 1) * 2 + 3).Resize(, 2).Merge

Next i

Sheets("工作表1").Shapes("combo_0").ControlFormat.Value = i - 1

With Sheets("工作表2")
.Range("a2:b17").Value = Sheets("工作表1").Range("c3:d18").Value
.Range("a19") = "股東人數"
.Range("b1") = Sheets("工作表1").ListBoxes("list_0").List(Sheets("工作表1").ListBoxes("list_0")) & vbNewLine & "~" & vbNewLine & Sheets("工作表1").ListBoxes("list_1").List(Sheets("工作表1").ListBoxes("list_1"))
.Cells.Font.Bold = True
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlCenter
.Range("c3:d17").Resize(, (i - 1) * 2).NumberFormatLocal = "#,##0_ "

.Columns.AutoFit
End With

Call SetFormatCondition(Sheets("工作表2").Range("c3:d17").Resize(, (i - 1) * 2))


End Sub





使用方式
一、先選好日期
二、按產生總表
三、點選工作表2
總表排列方式,照“常用股票”工作表中的股票代碼順序

常用股票工作表中的清單,請自行複製到新檔
access資料庫 stock.accdb,可延用不需重新下載
[點擊下載]
好專業分享努力學習中.
版主,有空可以幫我看一下,我不知道為什麼滙入前面儲存格內容不一樣...,我要這麼修改成[純文字]謝謝.

Sub 券商()
Sheets("券商").Select '指定工作表
Sheets("券商").Range("a1:k3000").Clear '清除工作表內容
Dim url, HTMLsourcecode, GetXml
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
url = "http://jsjustweb.jihsun.com.tw/z/zg/zgb/zgb0.djhtm?a=8880&b=8882&c=E&d=20"
With GetXml
.Open "GET", url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
HTMLsourcecode.body[removed] = .responseText
Set Table = HTMLsourcecode.all.tags("table")(3).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innerText
Next j
Next i
End With
Set HTMLsourcecode = Nothing
Set GetXml = Nothing
Range("A1").Select
'ActiveWorkbook.Save '儲存
End Sub


g80860 wrote:
我不知道為什麼滙入前面儲存格內容不一樣



每列的第一格都是網頁連結
從網頁原始碼可知,有2種寫法
genlink2stk+href =>innertext 是空白的
href =>innertext 有資料




所以用innertext取資料,就會像下圖這樣,出現一些空白資料





解決方式很簡單,innertext空白,就改取innerhtml





但是innerhtml會包含一些語法,所以要處理、拆解字串






If j = 0 And Len(Table(i).Cells(j).innertext) = 0 Then
ActiveSheet.Cells(i + 1, j + 1) = Split(Split(Table(i).Cells(j).innerhtml, "GenLink2stk('AS")(1), "')")(0)
ActiveSheet.Cells(i + 1, j + 1) = Replace(ActiveSheet.Cells(i + 1, j + 1), "','", "")
Else
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
End If

版主:如前發問...我不知道是不是那有問題,還是跑不出跟版主相同結果,可以求助怎麼完成跑出,感謝.

Sub 券商()
Sheets("券商").Select '指定工作表
Sheets("券商").Range("a1:k3000").Clear '清除工作表內容

Dim url, HTMLsourcecode, GetXml
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
url = "http://jsjustweb.jihsun.com.tw/z/zg/zgb/zgb0.djhtm?a=8880&b=8882&c=E&d=20"
With GetXml
.Open "GET", url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
HTMLsourcecode.body.innerhtml = .responseText
Set Table = HTMLsourcecode.all.tags("table")(3).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
Next j
Next i
End With
Set HTMLsourcecode = Nothing
Set GetXml = Nothing
'-------------------------------------
If j = 0 And Len(Table(i).Cells(j).innertext) = 0 Then
ActiveSheet.Cells(i + 1, j + 1) = Split(Split(Table(i).Cells(j).innerhtml, "GenLink2stk('AS")(1), "')")(0)
ActiveSheet.Cells(i + 1, j + 1) = Replace(ActiveSheet.Cells(i + 1, j + 1), "','", "")
Else
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
End If
'-------------------------------------

Range("A1").Select
'ActiveWorkbook.Save '儲存
End Sub
g80860 wrote:
我不知道是不是那有問題

實在不曉得,為什麼跑不過去??版主有空在幫我跑看看,謝謝.
Sub 券商()
Sheets("暫存區").Select '指定工作表
Sheets("暫存區").Range("a1:k3000").Clear '清除工作表內容
Dim url, HTMLsourcecode, GetXml
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml = CreateObject("msxml2.xmlhttp")
url = "http://jsjustweb.jihsun.com.tw/z/zg/zgb/zgb0.djhtm?a=8880&b=8882&c=E&d=20"
With GetXml
.Open "GET", url, False
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
'------------------------------------
'.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
'------------------------------------
.send
HTMLsourcecode.body [removed] = .responseText
Set Table = HTMLsourcecode.all.tags("table")(3).Rows
For i = 0 To Table.Length - 1
For j = 0 To Table(i).Cells.Length - 1
'ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innerText
'------------------------------------
If j = 0 And Len(Table(i).Cells(j).innertext) = 0 Then
ActiveSheet.Cells(i + 1, j + 1) = Split(Split(Table(i).Cells(j).innerhtml, "GenLink2stk('AS")(1), "')")(0)
ActiveSheet.Cells(i + 1, j + 1) = Replace(ActiveSheet.Cells(i + 1, j + 1), "','", "")
Else
ActiveSheet.Cells(i + 1, j + 1) = Table(i).Cells(j).innertext
End If
'------------------------------------
Next j
Next i
End With
Set HTMLsourcecode = Nothing
Set GetXml = Nothing
Range("A1").Select
'ActiveWorkbook.Save '儲存
End Sub

g80860 wrote:
為什麼跑不過去??


(點我看大圖)
感謝版主回覆解答.
關閉廣告
文章分享
評分
評分
複製連結
請輸入您要前往的頁數(1 ~ 143)

今日熱門文章 網友點擊推薦!