麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 可否用迴圈或變數匯入大量資料？ [打印本頁]

作者: smart3135 時間: 2014-4-22 00:54 標題: 有沒有方法可以用EXCEL VAB抓取上市櫃所有個股的資訊?

想請問各位先進，小弟最近在學EXCEL VBA，想利用EXCEL VBA下載個股的一些資訊，如各季各年的損益表、資產負債表、現金流量表、月營收、年度股利等等資料
目前是有寫出一個EXCEL VBA能抓取單獨個股的資訊，但如果想要更換其他個股，就必須將這個檔案複製另存成另一個檔案，再打開檔案進到visual basic編緝器將
裡面的個股代號以取代的方式變更，如果要這樣一個一個複製完成上市櫃所有的個股excel應該是很沒有效率的，不知道有沒有方法能一次下載很多個股的資料呢？
附上我自己寫的EXCEL VBA，還請各位大大幫忙解惑，感謝！
[attach]18107[/attach]

作者: smart3135 時間: 2014-4-22 19:02 標題: 可否用迴圈或變數匯入大量資料？

請問一下各位先進，這是我從某網站匯入EXCEL的程式碼，不知道能不能使用迴圈或變數的方式取其他個股相同的財報？
也就是程式碼中的2330可以用迴圈或變數來變更嗎？懇請各位VBA高手指點，謝謝！
https://www.cathayholdings.com/securities/exclude_AL/market.aspx?btn=1-00-00&st=2330

Sub 抓季損益表資料()
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=2330", Destination _
:=Range("$A$1"))
.Name = "ZCQ.DJHTM?A=2330"
.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 = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Sub End

複製代碼

作者: GBKEE 時間: 2014-4-22 20:39

回復 2# smart3135
試試看

Option Explicit
Sub 抓季損益表資料()
Dim Rng As Range, AR(), URL As String, E As Variant
For E = Sheets.Count To 2 Step -1
Sheets(E).Delete '工作表刪除
Next
AR = Array(2303, 2485, 2030)
Sheets(1).Range("A1:A3") = Application.WorksheetFunction.Transpose(AR)
Set Rng = Sheets(1).Range("A1:A3")
For Each E In Rng '迴圈儲存格
' For Each E In AR '迴圈也可以用陣列
With Sheets.Add(, Sheets(1)) '新增工作表
.Name = E
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=" & E
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Name = "ZCQ.DJHTM?A=" & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
End With
Next
End Sub

複製代碼

作者: smart3135 時間: 2014-4-23 00:37

回復 3# GBKEE
感謝GBKEE大大指點新手，目前人在上班，等下班再來測試結果，也會試著了解其中的語法，有問題再請您多多指點，再次感謝！

作者: smart3135 時間: 2014-4-23 09:46

回復 3# GBKEE
感謝GBKEE版主的分享，這個真的是太棒了，雖然我裡面很多的程式碼和語法我還是一知半解，但確實是有接近我想要寫出的結果
另外有個問題請教一下，就是AR = Array(2303, 2485, 2030)只能一個一個代號加入，能否寫成用一個區間範圍來設定
例如1101-2330之間所有符合的股票代號，並讓VBA自行判定非股票代碼的數字就不是抓資料，再請指點，感謝！

作者: GBKEE 時間: 2014-4-23 20:37

回復 5# smart3135

Option Explicit
Sub 抓季損益表資料()
Dim E As Integer
Application.DisplayAlerts = False '停止系統的警告提示
For E = 1101 To 2330
With Sheets.Add(, Sheets(1)) '新增工作表
.Name = E
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A=" & E
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Name = "ZCQ.DJHTM?A=" & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If .[A1] = -E Then '這網頁如股票代碼錯誤會傳回負號.
Stop 'STOP 是給你回到工作表驗證用,可刪掉這程式碼
ActiveSheet.Delete
End If
End With
Next
Application.DisplayAlerts = True '程式結速:恢復系統的警告提示
End Sub

複製代碼

作者: smart3135 時間: 2014-4-24 06:33

回復 6# GBKEE
感謝版主的回答，另外想再請教一個問題，不知道VBA有沒有辦法將我抓取下來的資料貼到記事本再自動存檔
之前有嚐試過，但EXCEL VBA似乎沒法控制EXCEL以外的軟體或程式，後來我是使用EXCEL另存新檔中的存成
文字檔(tab字元分隔)(*txt)，這樣可以存成文字檔，不過不知道存檔的路徑資料夾有沒有辦用先前做出迴圈的變數E來指定
例如：我想將抓取下來的1101季損益表先放到sheet(1)，再另存成XYZ.TXT，存檔路徑是C:\E\XYZ.TXT
其中E就是我希望能隨著抓取的股票代號一起變更的變數，也就是若抓取的資料是1101，那麼存檔路徑就是C:\1101\XYZ.TXT
存檔路徑資料夾若VBA有辦法利用程式碼新增當然最好，如果沒辦法的話我可以自己建立，完成後將1101季損益表的工作表刪除，
再新增下一個1102季損益表的工作表，再重覆上述的動作，問題有點多，希望我表達的意思不會太難懂，再麻煩大大囉！感謝！

作者: GBKEE 時間: 2014-4-24 09:07

本帖最後由 GBKEE 於 2014-4-24 09:11 編輯

回復 7# smart3135
試試看

Option Explicit
Sub 抓季損益表資料()
Dim E As Integer, URL As String, xPath As String
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
xPath = "C:\季損益表"
'存檔路徑是C:\E\XYZ.TXT, 建議改為 C:\季損益表\1101.txt
With ThisWorkbook
' If .Sheets.Count = 1 Then .Sheets.Add '配合讀取txt檔到工作表時必須有2張工作表
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
For E = 1101 To 2330
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If .[A1] <> -E Then '這網頁如股票代碼錯誤會傳回負號.
If Dir(xPath, vbDirectory) = "" Then MkDir xPath '目錄不存在則新徵增此目錄
Maketxt xPath & "\" & E & ".TXT", .QueryTables(1)
'Redalltxt xPath & "\" & E & ".TXT" '讀取txt檔到工作表
End If
Next
End With
End With
End Sub
Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub Redalltxt(xF As String) '
Dim fs As Object, E, D As New DataObject
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xF, 1)
E = fs.readall
fs.Close
With D
.SetText E
.PutInClipboard
With Sheets(2)
.UsedRange.Clear
.Activate
.Range("A1").Select
.PasteSpecial Format:="Unicode 文字"
.Cells.Font.Size = 12
.Cells.Font.Bold = False
.Cells.EntireColumn.AutoFit
End With
End With
End Sub
Sub Set_FormDLL() '新增引用 Microsoft Forms 2.0 Object Library
On Error Resume Next
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
'2003版的目錄為 C:\windows\system32\ ,你需修改此目錄
End Sub

複製代碼

[attach]18130[/attach]

作者: smart3135 時間: 2014-4-24 09:35

回復 8# GBKEE
WOW，GBKEE版主真的太神了，裡面的語法有好多還看不懂，目前正用逐行執行來了解，慢慢消化吸收，很感謝您的回答
不過可能我前面表達的不是很清楚，就您的程式碼來說，產生的結果會變成在C:\季損益表\1101.txt，1102.txt，1103.txt
也就是在C槽季損益表資料夾下會產生一個個照個股代碼命名的txt檔，但我希望產生的結果是C:\季損益表\1101\ISQ.txt
C:\季損益表\1102\ISQ.txt，C:\季損益表\1103\ISQ.txt，也就是txt檔名是固定的，由我自己指定檔名，這裡是先預設ISQ.txt
而能隨著個股代碼變動的是資料夾名稱，資料夾若無法由VBA產生我可以自行建立，不知道VBA有沒有辦法做到這樣的結果
再次懇請大大指點迷津，感謝！

[attach]18131[/attach]
[attach]18132[/attach]

作者: GBKEE 時間: 2014-4-24 10:05

本帖最後由 GBKEE 於 2014-4-25 05:45 編輯

回復 9# smart3135

Option Explicit
Sub Ex()
MkDir_Sub "D:\Test\季損益表\1103\ISQ.txt"
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
'如S參數所接收字串="D:\MYSUB\ABC\1101.TXT
'Split函數將S以"\"分割為陣列
'AR(0) = "D:"
'AR(1) = "MYSUB"
'AR(2) = "ABC"
'AR(3) = "1101.TXT"
'UBound(AR)傳回AR陣列的上限元素索引值,3
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
'MkDir : 創建目錄
Next
End If
End Sub

複製代碼

作者: smart3135 時間: 2014-4-24 10:13

回復 8# GBKEE
再補充一下，當抓取資料的網站查無該資料時就會出錯，因為我的連結是抓損益季表(合併財報)，而當個股無合併財報可抓取資料時就會出錯
但查詢損益表(季表)是有資料的，不知VBA程式碼能不能做到當主要網頁資料[損益季表(合併財報)]抓不到時就去抓次要網頁資料[損益表(季表)]
[attach]18133[/attach]

損益季表(合併財報0
[attach]18134[/attach]

損益表(季表)
[attach]18135[/attach]

作者: smart3135 時間: 2014-4-24 13:41

本帖最後由 smart3135 於 2014-4-24 13:43 編輯

回復 smart3135
試試看
GBKEE 發表於 2014-4-24 09:07

呼！花了點時間慢慢研究一個個程式碼的意思及語法，再將GBKEE版大提供的程式碼稍做修改，終於完成了！現在只要執行VBA就能將我要的ISQ.TXT檔放在
迴圈變數E所產生的資料夾下，也就是C:\季損益表\1101\、C:\季損益表\1102\，唯一要注意的是C槽下的季損益表資料夾一定要自己先建立，否則執行程式時會出錯
現在就只剩下上一篇提出的問題：當抓取網頁資料時若無資料要如何跳過或去抓取有資料的網頁以避免出錯，再請GBKEE大大指點囉！感恩！

Option Explicit
Sub 抓季損益表資料()
Dim E As Integer, URL As String, xPath As String, ISQ As String
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
For E = 1101 To 2330
xPath = "C:\" & "季損益表" & "\" & E & "\"
'存檔路徑是C:\E\XYZ.TXT, 建議改為 C:\季損益表\1101.txt
With ThisWorkbook
' If .Sheets.Count = 1 Then .Sheets.Add '配合讀取txt檔到工作表時必須有2張工作表
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If .[A1] <> -E Then '這網頁如股票代碼錯誤會傳回負號.
If Dir(xPath, vbDirectory) = "" Then MkDir xPath '目錄不存在則新徵增此目錄
Maketxt xPath & "ISQ.TXT", .QueryTables(1)
'Redalltxt xPath & "\" & E & ".TXT" '讀取txt檔到工作表
End If
End With
End With
Next
End Sub
Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub Redalltxt(xF As String) '
Dim fs As Object, E, D As New DataObject
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xF, 1)
E = fs.readall
fs.Close
With D
.SetText E
.PutInClipboard
With Sheets(2)
.UsedRange.Clear
.Activate
.Range("A1").Select
.PasteSpecial Format:="Unicode 文字"
.Cells.Font.Size = 12
.Cells.Font.Bold = False
.Cells.EntireColumn.AutoFit
End With
End With
End Sub
Sub Set_FormDLL() '新增引用 Microsoft Forms 2.0 Object Library
On Error Resume Next
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
'2003版的目錄為 C:\windows\system32\ ,你需修改此目錄
End Sub

複製代碼

作者: GBKEE 時間: 2014-4-24 16:55

本帖最後由 GBKEE 於 2014-4-24 17:04 編輯

回復 12# smart3135

Option Explicit
Sub 抓季損益表資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim Msg As Boolean
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCQ/ZCQ.DJHTM?A="
xPath = "C:\季損益表"
With ThisWorkbook
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
For E = 1339 To 2330
ER:
With .QueryTables(1)
If Msg = False Then
.Connection = URL & E
ElseIf Msg Then
'https://djinfo.cathaysec.com.tw/z/zc/zcq/zcq0_1339_ACC.djhtm 損益表(累計季表)
.Connection = "URL;https://djinfo.cathaysec.com.tw/z/zc/zcq/zcq0_" & E & "_ACC.djhtm"
End If
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If InStr(.[A3], "查無") Then Msg = True: GoTo ER
If InStr(.[A3], "個股代碼錯誤") = 0 Then '這網頁如股票代碼錯誤會傳回負號.
xFile = xPath & "\" & E & "\ISQ.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, .QueryTables(1)
End If
Msg = False
Next
End With
End With
End Sub

複製代碼

作者: smart3135 時間: 2014-4-24 19:54

回復 13# GBKEE
抱歉，GBKEE大大，圖片中的語法一開始就執行錯誤，不知道是否語法有誤，這段語法真的看不懂，再請您教導一下，感謝！
[attach]18146[/attach]

作者: GBKEE 時間: 2014-4-24 20:11

回復 14# smart3135
註解有在看嗎? 要複製第10#的 MkDir_Sub 程式到模組上.

作者: smart3135 時間: 2014-4-24 20:49

回復 15# GBKEE
Sorry，剛剛註解是有看了，不過不太懂意思，原來是要把先前#10的程式碼放到模組中，之後就解決了
VBA執行大量迴圈後似乎會佔用記憶體的空間，導致迴圈的執行到後面會越來越慢，不知道我的觀念對不對
目前正在搜索有關釋放記憶體的文章，再次大力感謝GBKEE大大不厭其煩的指導^^:handshake

作者: smart3135 時間: 2014-4-25 05:23

本帖最後由 smart3135 於 2014-4-25 05:25 編輯

回復 8# GBKEE
GBKEE版主您好，昨天您提到將EXCEL匯入的資料存入指定的txt，我用逐行執行，發現它是用迴圈的方式，將EXCEL匯入的資料一列一列的存入指定的txt中
直到遇到空白資料即停止迴圈不再存入，想請問若要將EXCEL匯入的資料存入到txt中，是只能用這種一列一列存入的方式嗎？
這種方式應該就像是點選EXCEL的第一列，然後按滑鼠右鍵複製(或Ctrl+C)，再貼到txt中的第一列，第二列資料就換到EXCEL第二列重覆一樣的動作
直到沒有資料能貼上為止，不知道我這樣解讀對不對，主要是想請問，有沒有方法能讓EXCEL資料，像點選EXCEL左上角的全選(Cells.select)，然後直接全部複製，
再全部直接貼到txt中，這樣應該就不用走迴圈，一次貼上即可，因為不清楚VBA有沒有語法能做到這樣，所以要再請您幫忙解惑一下囉！感謝！

Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: GBKEE 時間: 2014-4-25 05:57

本帖最後由 GBKEE 於 2014-4-25 07:28 編輯

回復 17# smart3135
10# 的程式碼看不懂,已加註說明了.
會出現記憶體不足的視窗,在XP,記憶體1GB,2003版,執行5分鐘內可完成,擴充你的記憶體試試看
全部直接貼到txt中，這樣應該就不用走迴圈,慢慢再研究.

作者: smart3135 時間: 2014-4-25 06:21

本帖最後由 smart3135 於 2014-4-25 06:22 編輯

回復 18# GBKEE
不好意思，又發現一個問題要來請教您了，先前有向您請教當損益季表(合併財報)的資料抓不到時，就去抓損益表(季表)，其中的關鍵字是在A3儲存格
鍵入查無，則第一個連結抓不到時就會去抓第二個連結的資料，但我在試著抓損益年表時，當個股不存在時，不是出現個股代碼錯誤，而是在A3出現查無損益年表(合併報表)
這時會去抓第二個連結，結果一樣會在A3出現查無損益年表，這時就無法跳出迴圈，變成一直在迴圈裡打轉了，兩個無法抓取資料的連結都在A3出現相同的關鍵字
以致程式碼無法區別，就持續走無盡迴圈，不知道這個問題有沒有辦法解決？資料一次貼上的方式我會再慢慢try，感謝您耐心的回答，謝謝！

Option Explicit
Sub 抓年損益表資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim Msg As Boolean
URL = "URL;https://djinfo.cathaysec.com.tw/z/zc/zcq/zcqa/zcqa.djhtm?A="
xPath = "G:\財報資料"
With ThisWorkbook
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
For E = 1341 To 2000
ER:
With .QueryTables(1)
If Msg = False Then
.Connection = URL & E
ElseIf Msg Then
'https://djinfo.cathaysec.com.tw/z/zc/zcq/zcqa/zcqa0_1339_ACC.djhtm 損益表(年表)
.Connection = "URL;https://djinfo.cathaysec.com.tw/z/zc/zcq/zcqa/zcqa0_" & E & "_ACC.djhtm"
End If
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If InStr(.[A3], "查無") Then Msg = True: GoTo ER
If InStr(.[A3], "個股代碼錯誤") = False Then '這網頁如股票代碼錯誤會傳回負號.
xFile = xPath & "\" & E & "\IS.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, .QueryTables(1)
End If
Msg = False
Next
End With
End With
End Sub

複製代碼

作者: smart3135 時間: 2014-4-25 06:44

回復 18# GBKEE
抱歉，剛剛試著試著，好像成功了，造成您的困擾，真不好意思！

作者: GBKEE 時間: 2014-4-25 07:15

回復 19# smart3135
你用的是 https://djinfo.cathaysec.com.tw/z/zc/zcq/zcqa/zcqa.djhtm
可修改如下

End With
If InStr(.[A3], "查無") And Msg = True Then GoTo xlNext
If InStr(.[A3], "查無") Then Msg = True: GoTo ER
If InStr(.[A3], "個股代碼錯誤") = False Then '這網頁如股票代碼錯誤會傳回負號.
xFile = xPath & "\" & E & "\IS.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, .QueryTables(1)
End If
xlNext:
Msg = False
Next

複製代碼

作者: smart3135 時間: 2014-4-25 10:43

本帖最後由 smart3135 於 2014-4-25 10:46 編輯

回復 21# GBKEE

1420月營收

GBKEE版主您好，請見以上連結，目前已無1420這支個股，因為1420潤泰紡織已併入2915潤泰全，但該網站仍將1420直接顯示2915潤泰全的合併月膋收
在VBA在擷取合併月營收時仍會擷取到資料，我試了很久，try了很多條件仍無法避免，不知能否利用VBA寫出類似像您在21#回覆的程式碼避免擷取到這種已無個股代號的資料呢？謝謝！
[attach]18160[/attach]

作者: GBKEE 時間: 2014-4-25 11:18

本帖最後由 GBKEE 於 2014-4-25 12:47 編輯

回復 22# smart3135

End With
If E = 1420 Then GoTo xlNext '加上試試看
'If InStr(.[A3], "查無") And Msg = True Or E = 1420 Then GoTo xlNext '或者可這樣寫
If InStr(.[A3], "查無") Then Msg = True: GoTo ER
If InStr(.[A3], "個股代碼錯誤") = False Then '這網頁如股票代碼錯誤會傳回負號.
xFile = XPath & "\" & E & "\IS.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, .QueryTables(1)
End If
xlNext:
Msg = False
Next

複製代碼

作者: smart3135 時間: 2014-4-25 11:52

回復 23# GBKEE
GBKEE版主您好，將您的程式碼套入之後是可以將1420跳過不抓資料了，不過因為1420也是在迴圈變數E的其中一碼，是不是無法用迴圈方式去避免抓取資料
只能一個一個像這樣[If E = 1420 Then GoTo xlNext]設定讓它跳過呢？因為像這種股票還真不少，要一個一個找出來可能要花些功夫
另外像這段[If InStr(.[A3], "查無") And Msg = True Or E = 2149 Then GoTo xlNext]當中的2149是代表什麼呢？我把Or E = 2149拿掉似乎不影響擷取資料
這個網站的資料出現"查無"是在A2儲存格，所以我把A3改成A2，附上程式碼，謝謝！

Option Explicit
Sub 抓季月營收資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim Msg As Boolean
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
xPath = "G:\財報資料"
With ThisWorkbook
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
Rows(1).Delete
Columns(1).Delete
For E = 1101 To 3000
ER:
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
If E = 1420 Then GoTo xlNext '加上試試看
If InStr(.[A2], "查無") And Msg = True Then GoTo xlNext
If InStr(.[A2], "查無") Then Msg = True: GoTo ER
If InStr(.[A3], "個股代碼錯誤") = False Then '這網頁如股票代碼錯誤會傳回負號.
xFile = xPath & "\" & E & "\REVENUE.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, .QueryTables(1)
End If
xlNext:
Msg = False
Next
End With
End With
End Sub

複製代碼

作者: GBKEE 時間: 2014-4-25 13:03

回復 24# smart3135
1420 key錯成 2149 可簡化不需 If E = 1420 Then GoTo xlNext

Rows(1).Delete
Columns(1).Delete
AR = Array(1420, 1580, 2000) '你是要一個一個找出的
For E = 1101 To 3000
X = Application.Match(E, AR, 0)
If IsNumeric(X) Then GoTo xlNext '直接到 xlNext行
' 'If E = 1420 Then GoTo xlNext '不需要
ER:
With .QueryTables(1)

複製代碼

作者: smart3135 時間: 2014-4-25 13:40

回復 25# GBKEE
感謝版主的回覆，看來我只能一個一個把有問題的找出來了，不過照您25#回覆的程式碼，可以簡化一些，感謝幫忙
另外我發現這個擷取資料的VBA最花時間的地方就是在將EXCEL資料一列一列匯入到txt，之前有向您提及我要自己try看看能不能用一次貼上的方式
但try了很多次仍是無法達成，主要在於對程式碼較不了解，比較不清楚怎麼做變化，因為匯入的資料要從1101~9962，資料蠻龐大的，若跑完整個VBA
大約要耗時40分鐘以上，所以才希望能夠讓程式的動作再簡化一些，這應該是最後一次需要做修正了，如果可以的話再請版主多指點一下囉！萬分感謝！
附上您先前提供的程式碼

Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

另外25#中的AR及X未定義，我直接將兩個都定義成Variant，就可以順利執行程式了

作者: GBKEE 時間: 2014-4-25 18:55

本帖最後由 GBKEE 於 2014-4-26 15:42 編輯

回復 26# smart3135
大約要耗時40分鐘以上,是有點久,電腦要減肥了
建議減肥方式如下
1將下面文字複製到記事本存檔為附檔名 ".BAT",傳送到桌面上 ,不定時的清理垃圾檔案
2不定時的清空資源回收筒
3 不定時清空IE的瀏覽記錄
4 定時的清理磁碟
5擴充記憶體

4203天仁(後抓取)是錯誤的股票號碼,這些股票名稱(代號) 連續一起輸入在Sheets(2)的A欄

Option Explicit
Sub 抓季月營收資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
Dim AR()
t = Time
AR = Array(4203) '輸入 4203天仁(後抓取)是錯誤的股票號碼
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
xPath = "D:\財報資料"
With ThisWorkbook
.Sheets(2).UsedRange.Offset(, 1).Clear
'4203天仁(後抓取)是錯誤的股票號碼這些股票名稱(代號) 連續一起輸入在Sheets(2)的A欄
Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
If Rng Is Nothing Then
AR = Array()
ElseIf Rng.Count = 1 Then
AR = Array(Rng.Value)
Else
AR = Application.Transpose(Application.Transpose(Rng))
End If '***************************************************
Application.ScreenUpdating = False
Application.StatusBar = " "
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
.Rows(1).Delete
.Columns(1).Delete
For E = 1101 To 5000
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
If .ResultRange(1) < 0 Or InStr(.ResultRange(2, 1), "查無") Then GoTo xLnext
'匯入資料的 A1 < 0 OR 匯入資料的 A2 "查無"
S1 = .ResultRange(1)
S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
End With
With ThisWorkbook.Sheets(2).Range("B:B")
Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
If Rng Is Nothing Then
i = i + 1
.Range("A" & i) = S1 '股票名稱代碼
Else
Rng.Cells(1, 2) = S1 '重複的股票
If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then
'Filter(AR, E) > -1 '比對到如4203天仁(後抓取)是錯誤
Rng.Cells(1, 2) = Rng.Cells(1, 2) & "***" '後抓取是錯誤
GoTo xLnext:
End If
S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
S2 = Mid(S2, 1, Len(S2) - 1) '舊的股票[代碼]
xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
If Dir(xFile) <> "" Then
ii = ii - 1
Kill xFile
xFile = xPath & "\" & S2
If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
End If
End If
End With
ii = ii + 1
xFile = xPath & "\" & E & "\REVENUE.txt"
MkDir_Sub xFile
Maketxt xFile, .QueryTables(1)
xLnext:
S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
If Val(S1) < 0 Then S1 = " 查無"
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " " & E & S1
Next
End With
End With
Application.ScreenUpdating = True
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " Ok "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
End Sub
Private Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-4-26 11:25

回復 27# GBKEE
GBKEE版主您好，今早下班後就開始在Try您在27#回覆的程式碼，結果的確會將一些重覆的個股txt刪除，但不知有沒有辦法將一起建立的資料夾也刪除呢？
舉例來說，1202和2913兩個都是農林，所以程式執行完會將1202的txt刪除，但1202的資料夾仍是存在的，不知沒有沒辦法連資料夾一起刪除呢？
另外還有一個問題，就是這個程式碼保留的資料都是sheet(2)的第二欄個股代號資料，若我沒解讀錯誤的話，程式應該是將個股代碼相同，先抓取的txt刪除，保留後抓取的txt
但就會遇到1233天仁(先抓取)是正確的，4203天仁(後抓取)是錯誤的問題，結果就是正確的1233天仁txt被刪除，這部分我想應該不太好解決
所以，如果可以的話，我還是傾向在您24#回覆的程式碼，用一個一個挑出的方式，這些不需要的代號我都有了，只要輸入AR=Array()中就可以了，只是我要輸入的代號
大概有200個左右，如果全部輸入，如AR=Array(1202,1433,1502,1610.....................)這樣要把200個代碼全部輸入會跳到第二行，然後就會出錯，不知道有沒有辦法
解決這個問題呢？先感謝您的指導！
[attach]18170[/attach]

作者: smart3135 時間: 2014-4-26 14:22

回復 27# GBKEE
版主，不好意思，再請教一個問題，現在我要設定迴圈為for E = 1101 9962，但我已經知道某些數字區間是不需要去擷取的，如果想跳過該使用怎樣的語法呢？先謝謝您！
大概的構想如下:

Dim E As Integer
For E = 1101 To 2000
IF E = 3800到4100 then goto xlNext '想設定某個區間,請教語法該怎麼設
IF E = 6850到8000 then goto xlNext '想設定某個區間,請教語法該怎麼設
IF E = 8550到9000 then goto xlNext '想設定某個區間,請教語法該怎麼設
IF E = 9000到9800 then goto xlNext '想設定某個區間,請教語法該怎麼設,共四個區間
xlNext:
next
End sub

複製代碼

作者: GBKEE 時間: 2014-4-26 15:45

本帖最後由 GBKEE 於 2014-4-26 15:52 編輯

回復 29# smart3135
1233天仁(先抓取)是正確的，4203天仁(後抓取)是錯誤的問題
這一些錯誤股票名稱(代號) 天仁(4203) 連續一起輸入在Sheets(2)的A欄,後程式可解決.

28# 的所有問題.27#程式碼已更新了,可再看一次,減肥有試一下嗎?

試試看

Sub Ex()
Dim E As Integer
For E = 500 To 5000
Select Case E
Case 500 To 1000
GoTo xNext
Case 1500 To 2000
GoTo xNext
Case 2500 To 3000
GoTo xNext
End Select
MsgBox E
xNext:
Next
End Sub
Sub Ex1()
Dim E As Integer
For E = 500 To 5000
If E >= 500 And E <= 1000 Or E >= 1500 And E <= 2000 Or E >= 2500 And E <= 3000 Then
GoTo xNext
End If
MsgBox E
xNext:
Next
End Sub

複製代碼

作者: smart3135 時間: 2014-4-26 19:13

回復 30# GBKEE
先感謝GBKEE版主一一耐心的回答，因為今晚還要上班，所以您在27#更新的程式碼，可能要等到明天才能try了！
至於電腦減肥部分
1將下面文字複製到記事本存檔為附檔名 ".BAT",傳送到桌面上 ,不定時的清理垃圾檔案－這個BAT檔我一直都有在用，是否每次執行完VBA就要清一次呢？
2不定時的清空資源回收筒－最近丟到資源回收筒的資料較多，有空會試一下清空會不會好一點
3 不定時清空IE的瀏覽記錄－平常都是用chorme流灠器為主，不過最近因為要EXCEL匯入WEB資料所以有比較常用，會清空再來試試
4 定時的清理磁碟－兩天前才剛將磁碟重組
5擴充記憶體－我的系統是WIN7 64位元+office 2007，記憶體是4G，不知道這樣有需要擴充嗎？

我有發現會跑那麼久是因為我給的區間越大，程式跑到越後面就越慢，例如我程式碼設定For E = 1101 to 9962，只執行一次，跑起來可能需要40分鐘
但我將程式碼設定For E = 1101 to 3000，For E = 3001 to 5000，For E = 5001 to 7000，For E = 7001 to 9962，共執行四次，合計起來的時間就不需要那麼久
E的區間設定越小，完成的時間就越短，這部分就不太理解為什麼會這樣了！

另外雖然您在27#的程式碼已更新，不過還是希望能了解一下我在28#向您提問的AR=Array(1202,1433,1502,1610.....................)這樣要把200個代碼全部輸入
會跳到第二行，然後就會出錯，不知道有沒有辦法解決這個問題呢？
不知道這個AR的Array區間有沒有辦法輸入200個引數以上呢？

作者: GBKEE 時間: 2014-4-26 20:21

本帖最後由 GBKEE 於 2014-4-26 20:22 編輯

回復 31# smart3135
這個BAT檔我一直都有在用，是否每次執行完VBA就要清一次呢？,你要跑這程式當然最好是的,檔案開開關關會製造一些暫存檔,就需要清一下
WIN7 64位元+office 2007，記憶體是4G，是不需擴充了,另就就開機時系統要載太入的常駐應用程式.佔據太多的記憶體.這也是主因之ㄧ.
XP,32位元, 1GB, 2003版, 27#程式 For 1101 To 5000的迴圈 ,減肥後7分鐘內搞定.
E的區間設定越小，完成的時間就越短，這部分就不太理解為什麼會這樣了,這是想當然的

Option Explicit
Sub Ex()
Dim Ar
Ar = Array(56, 78, _
9, 10, 12 _
, 888, 999, _
56789)
End Sub

複製代碼

[attach]18172[/attach]

作者: smart3135 時間: 2014-4-26 21:30

回復 32# GBKEE
哇 1101到5000跑完只要七分鐘好威！
我之前也有試過接下引號跳下一行，但一直失敗，原來要跳下一行前接的下引號後面要有空格，又學到一招了，再次感謝您的指導！

作者: smart3135 時間: 2014-4-27 09:55

回復 27# GBKEE
GBKEE版主早安，有些問題想請教您：
1.今早下班回來就馬上試了您昨天在27#提供的程式碼，我有再加上要跳過的代號在AR中，也照提示將代號都輸入到sheet(2)的A欄
直接跑一次，奇怪的事發生了，我設定For E = 1101 to 5000，每次跑到一半時就會出錯，出錯的位置是在If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then，不清楚哪裡出了問題
附上程式碼和檔案，請您幫忙看看　
2.另外我有發現您27#的程式碼在出錯前的執行時速度非常快，和您先前提供的程式碼讓我在23#完成的程式有很大的落差，這當中究竟有什麼差異呢？為什麼速度會差這麼多呢？
一樣我兩個VBA程式都有附上，也麻煩您幫忙看看為什麼會有如此大的差異
3.我用您先前提供的跑下來，第一段1101 to 5000，費時12分48秒，抓了992筆資料
第二段5001 to 9962，費時13分50秒，抓了515筆資料
我在跑第二段時有先使用清除系統的.bat檔，並將EXCEL關閉再開啟重新執行VBA，結果看來並沒有瘦身的效果，不知道為什麼會這樣？
4.另外在將資料匯入txt的程式碼中，如下
For Each E In Q.ResultRange.Rows
      C = Application.Transpose(Application.Transpose(E.Value))
      C = Join(C, vbTab)
      fs.WriteLine C
Next
其中Q.ResultRange.Rows的Rows是不是代表列，也就是將資料一列一列存入txt，直到沒有資料為止
之後我有想到，因為用一列一列的方式來匯入資料要跑很多次迴圈，如果是用一欄一欄的方式匯入就會少跑很多次迴圈
我有試著將Rows改為Columns，但執行到下二行的C = Join(C, vbTab)就會出錯，不知道有沒有辦法用欄的方式匯入呢？

問題有點多，再麻煩您幫忙一下囉！感謝！

Option Explicit
Sub 抓季月營收資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
Dim AR()
t = Time
AR = Array(1202, 1420, 1433, 1502, 1518, 1610, 1716, 2346, 2372, 2391, 2513, 2526, 2541, 2802, 2803, 2804, 2806, _
2813, 2814, 2815, 2817, 2818, 2819, 2821, 2826, 2830, 2839, 2840, 2843, 2844, 2848, 2907, 2909, 4101, 4112, _
4175, 4201, 4203, 4204, 4301, 4302, 4405, 4407, 4409, 4410, 4411, 4412, 4504, 4505, 4507, 4508, 4509, 4512, _
4514, 4516, 4517, 4519, 4520, 4521, 4524, 4525, 4531, 4603, 4604, 4605, 4606, 4607, 4608, 4701, 4704, 4705, _
4708, 4709, 4710, 4713, 4715, 4718, 4901, 4902, 5001, 5003, 5004, 5005, 5012, 5101, 5311, 5319, 5320, 5322, _
5323, 5327, 5330, 5331, 5334, 5335, 5337, 5341, 5342, 5354, 5357, 5358, 5359, 5360, 5361, 5362, 5363, 5366, _
5368, 5369, 5374, 5377, 5379, 5380, 5382, 5389, 5391, 5393, 5394, 5396, 5397, 5399, 5404, 5405, 5408, 5409, _
5411, 5412, 5415, 5416, 5417, 5418, 5419, 5420, 5421, 5422, 5423, 5424, 5427, 5428, 5430, 5431, 5433, 5435, _
5440, 5444, 5445, 5446, 5447, 5449, 5453, 5456, 5458, 5459, 5461, 5462, 5463, 5470, 5472, 5476, 5477, 5482, _
5485, 5486, 5495, 5496, 5499, 5509, 5517, 5527, 5606, 5705, 5804, 5805, 5806, 5807, 5809, 5812, 5814, 5815, _
5854, 6003, 6006, 6019, 6102, 6106, 6401, 6501, 8001, 8003, 8903, 8904, 8912, 8914, 8915, 8918, 8920, 8922, 8939, 9105, 9909)
'輸入 4203天仁(後抓取)是錯誤的股票號碼
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
xPath = "G:\財報資料"
With ThisWorkbook
.Sheets(2).UsedRange.Offset(, 1).Clear
'4203天仁(後抓取)是錯誤的股票號碼這些股票名稱(代號) 連續一起輸入在Sheets(2)的A欄
Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
If Rng Is Nothing Then
AR = Array()
ElseIf Rng.Count = 1 Then
AR = Array(Rng.Value)
Else
AR = Application.Transpose(Application.Transpose(Rng))
End If '***************************************************
Application.ScreenUpdating = False
Application.StatusBar = " "
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
.Rows(1).Delete
.Columns(1).Delete
For E = 1101 To 5000
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
If .ResultRange(1) < 0 Or InStr(.ResultRange(2, 1), "查無") Then GoTo xLnext
'匯入資料的 A1 < 0 OR 匯入資料的 A2 "查無"
S1 = .ResultRange(1)
S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
End With
With ThisWorkbook.Sheets(2).Range("B:B")
Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
If Rng Is Nothing Then
i = i + 1
.Range("A" & i) = S1 '股票名稱代碼
Else
Rng.Cells(1, 2) = S1 '重複的股票
If UBound(Filter(AR, E)) > -1 And UBound(AR) > -1 Then
'Filter(AR, E) > -1 '比對到如4203天仁(後抓取)是錯誤
Rng.Cells(1, 2) = Rng.Cells(1, 2) & "***" '後抓取是錯誤
GoTo xLnext:
End If
S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
S2 = Mid(S2, 1, Len(S2) - 1) '舊的股票[代碼]
xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
If Dir(xFile) <> "" Then
ii = ii - 1
Kill xFile
xFile = xPath & "\" & S2
If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
End If
End If
End With
ii = ii + 1
xFile = xPath & "\" & E & "\REVENUE.txt"
MkDir_Sub xFile
Maketxt xFile, .QueryTables(1)
xLnext:
S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
If Val(S1) < 0 Then S1 = " 查無"
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " " & E & S1
Next
End With
End With
Application.ScreenUpdating = True
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " Ok "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
End Sub
Private Sub MkDir_Sub(s As String)
Dim AR, i As Integer, xPath As String
If Dir(s) = "" Then
AR = Split(s, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Private Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18174[/attach]

作者: GBKEE 時間: 2014-4-27 15:13

本帖最後由 GBKEE 於 2014-4-27 15:24 編輯

回復 34# smart3135

Option Explicit
Private Sub Test()
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile("D:\財報資料\1101\Test.TXT", True)
'創見一個檔案,如檔案存在可覆蓋掉
'文字檔的寫入是
For Each E In Sheets(1).UsedRange.Columns
C = E.Value '-> 陣列(1 To 列數,1 To 欗數)的二維陣列
C = Application.Transpose(E.Value) '因為第二維只有一欄,轉置一次可變為一維陣列
'如E In UsedRange.rows
'C = E.Value '-> 陣列(1 To 列數,1 To 欗數)的二維陣列
'C = Application.Transpose(Application.Transpose(E.Value)) '第二維不只一欄,所以轉置二次才可變為一維陣列
C = Join(C, vbTab)
'Join 函數傳回一個字串，該字串是透過連結某個陣列中的多個子字串而建立的。
'Join 函數使用的陣列必須是一維陣列
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18175[/attach]

詳看註解可明瞭.

Option Explicit
Sub 抓季月營收資料()
Dim E As Integer, URL As String, xPath As String, xFile As String
Dim i As Integer, ii As Integer, Rng As Range, S1 As String, S2 As String, t As Date
Dim AR()
t = Time
URL = "URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCH/ZCH.DJHTM?A="
xPath = "D:\財報資料"
Application.DisplayStatusBar = True
With ThisWorkbook
'兩者取一即可 (選擇儲存格較方便)
'***'不需要的股票如4203天仁(後抓取)是錯誤的股票號碼置入-> Ar陣列
' AR = Array(1202, 1420, 1433, 1502, 1518, 1610, 1716, 2346, 2372, 2391, 2513, 2526, 2541, 2802, 2803, 2804, 2806, _
2813, 2814, 2815, 2817, 2818, 2819, 2821, 2826, 2830, 2839, 2840, 2843, 2844, 2848, 2907, 2909, 4101, 4112, _
4175, 4201, 4203, 4204, 4301, 4302, 4405, 4407, 4409, 4410, 4411, 4412, 4504, 4505, 4507, 4508, 4509, 4512, _
4514, 4516, 4517, 4519, 4520, 4521, 4524, 4525, 4531, 4603, 4604, 4605, 4606, 4607, 4608, 4701, 4704, 4705, _
4708, 4709, 4710, 4713, 4715, 4718, 4901, 4902, 5001, 5003, 5004, 5005, 5012, 5101, 5311, 5319, 5320, 5322, _
5323, 5327, 5330, 5331, 5334, 5335, 5337, 5341, 5342, 5354, 5357, 5358, 5359, 5360, 5361, 5362, 5363, 5366, _
5368, 5369, 5374, 5377, 5379, 5380, 5382, 5389, 5391, 5393, 5394, 5396, 5397, 5399, 5404, 5405, 5408, 5409, _
5411, 5412, 5415, 5416, 5417, 5418, 5419, 5420, 5421, 5422, 5423, 5424, 5427, 5428, 5430, 5431, 5433, 5435, _
5440, 5444, 5445, 5446, 5447, 5449, 5453, 5456, 5458, 5459, 5461, 5462, 5463, 5470, 5472, 5476, 5477, 5482, _
5485, 5486, 5495, 5496, 5499, 5509, 5517, 5527, 5606, 5705, 5804, 5805, 5806, 5807, 5809, 5812, 5814, 5815, _
5854, 6003, 6006, 6019, 6102, 6106, 6401, 6501, 8001, 8003, 8903, 8904, 8912, 8914, 8915, 8918, 8920, 8922, 8939, 9105, 9909)
'***A欄中不需要的股票如4203天仁(後抓取)號碼的儲存格置入-> Ar陣列
Set Rng = .Sheets(2).Range("A:A").SpecialCells(xlCellTypeConstants)
If Rng Is Nothing Then
AR = Array()
ElseIf Rng.Count = 1 Then
AR = Array(Rng.Value)
Else
AR = Application.Transpose(Rng.Value)
'先前出錯是這裡寫錯 AR = Application.Transpose(Application.Transpose(Rng.Value))
'Rng.Value=>單欄二維陣列
End If
'***************************************************
.Sheets(2).UsedRange.Offset(, 1).Clear
Application.ScreenUpdating = False
Application.StatusBar = " "
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
.Rows(1).Delete
.Columns(1).Delete
For E = 1101 To 5000
If UBound(Filter(AR, E)) > -1 Then GoTo xLnext
'Filter(AR, E)函數等同使用Find方法如 Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
With .QueryTables(1)
.Connection = URL & E
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
If InStr(.ResultRange(2, 1), "查無") Then '查無這檔股票
Mark_Code E '查無的股票放置A攔
GoTo xLnext
End If
S1 = .ResultRange(1) '匯入資料的第1個儲存格
S2 = Mid(S1, 1, InStr(S1, "(") - 1) '股票名稱
End With
With ThisWorkbook.Sheets(2).Range("B:B")
Set Rng = .Find(S2, lookat:=xlPart) '搜尋:股票名稱
If Rng Is Nothing Then
i = i + 1
.Range("A" & i) = S1 '股票名稱代碼
Else
Mark_Code E '重複的股票放置A攔
S2 = Mid(Trim(Rng), InStr(Trim(Rng), "(") + 1)
S2 = Mid(S2, 1, Len(S2) - 1) '舊的股票[代碼]
xFile = xPath & "\" & S2 & "\*.*" '殺掉所有檔案
If Dir(xFile) <> "" Then
ii = ii - 1
Kill xFile
xFile = xPath & "\" & S2
If Dir(xFile, vbDirectory) <> "" Then RmDir xFile '資料夾也刪除了
End If
End If
End With
ii = ii + 1
xFile = xPath & "\" & E & "\REVENUE.txt"
MkDir_Sub xFile
Maketxt xFile, .QueryTables(1)
xLnext:
S1 = " " & Sheets(1).QueryTables(1).ResultRange(1)
If Val(S1) < 0 Then S1 = " 查無"
Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入 " & ii & " 文字檔, 讀取 " & S1 & " 中..."
Next
End With
End With
Application.ScreenUpdating = True
Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.text(Time - t, ["MM分SS秒"])
ThisWorkbook.Save
End Sub

複製代碼

Private Sub Mark_Code(S As Integer)
With ThisWorkbook.Sheets(2).Range("A:A") '重複的股票放置A攔
.Cells(Application.Count(.Cells) + 1, "A") = S
'股票代號放置 A攔最後一個儲存格
'執行一次後,下次再執行 [抓季月營收資料]程式時,For 迴圈中可踢除這股票代號
End With
End Sub

複製代碼

[attach]18176[/attach]

作者: smart3135 時間: 2014-4-28 07:23

本帖最後由 GBKEE 於 2014-4-28 07:29 編輯

回復 35# GBKEE
感謝GBKEE版主這幾天來不斷的教導，真的讓我在EXCEL VBA上學習到很多，其他仍有許多需要擷取的資料，如資產負債表現金流量表等，這些我都能用這幾天學到的
稍加修改就能完成，唯獨有兩種資料比較特別，我無法獨立完成，所以又要再來請教GBKEE版主了
1.
上櫃月成交資訊
　上面連結為上櫃個股月成交資訊，即使輸入個股代號，網址仍不變，據了解是因為網頁為POST，並非GET，所以沒辦法擷取報表
　不知道有沒有辦法也用VBA做迴圈來擷取資料？(在EXCEL匯入WEB資料時似乎沒法等到下面的成交資訊表格來匯入資訊)
2.請件兩個EXCEL附件，這是在網路上面找到的，主要是要抓一年內的集保資料，但都只能用自行輸入的方式來一個一個擷取資料
　不知道有沒有辦法也用類似這兩天您所提供的程式碼來抓取集保資料，結果就如附件中的TXT檔，再麻煩您指點一下囉！感謝！

集保資料

[attach]18178[/attach]

作者: smart3135 時間: 2014-4-28 07:41

回復 35# GBKEE
抱歉檔案不知道為什麼上傳失敗所以再上傳一次
[attach]18180[/attach]

作者: GBKEE 時間: 2014-4-28 11:23

回復 37# smart3135
先回覆上櫃月成交資訊,事情忙完再繼續回覆你

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
' .Visible = True '不顯示ie
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃月成交資訊()
Dim E As Range, xPath As String, xFile As String, A As Object, FS As Object, F As Object
Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, c, s
Set FS = CreateObject("Scripting.FileSystemObject")
Ie_Url = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
t = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With IE
Set A = .Document.getelementbyid("input_stock_code")
A.Value = E
A.ParentNode.submit
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\上櫃月成交.txt"
MkDir_Sub xFile
With FS.CreateTextFile(xFile, True)
For i = 1 To A(2).Rows.Length - 1
s = ""
For c = 0 To A(2).Rows(i).Cells.Length - 1
s = s & A(2).Rows(i).Cells(c).innertext & vbTab
Next
.WriteLine s
Next
.Close
End With
ii = ii + 1
End With
Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next
IE.Quit
Application.StatusBar = Application.text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.text(Time - t, ["MM分SS秒"])
ThisWorkbook.Save
End Sub

複製代碼

作者: smart3135 時間: 2014-4-28 13:13

回復 38# GBKEE
GBKEE版主您好，這個程式碼我有試了，可以成功，不過不知道為什麼跑起來非常慢，上櫃公司統計共663家，我將它輸入到Sheets(3)的A欄
跑一個文字檔的時間大約要4-5秒，確定有清理系統了，不過還是非常慢
另外有辦法像之前將匯入資料顯示在EXCEL以便逐行執行時可以看出EXCEL如何變化，麻煩您了，謝謝！

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
' .Visible = True '不顯示ie
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃月成交資訊()
Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
Set fs = CreateObject("Scripting.FileSystemObject")
IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
t = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "G:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With IE
Set A = .Document.getelementbyid("input_stock_code")
A.Value = E
A.ParentNode.submit
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
With fs.CreateTextFile(xFile, True)
For i = 1 To A(2).Rows.Length - 1
S = ""
For C = 0 To A(2).Rows(i).Cells.Length - 1
S = S & A(2).Rows(i).Cells(C).innertext & vbTab
Next
.WriteLine S
Next
.Close
End With
ii = ii + 1
End With
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next
IE.Quit
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: GBKEE 時間: 2014-4-28 17:48

回復 39# smart3135
跑一個文字檔的時間大約要4-5秒，確定有清理系統了，不過還是非常慢 ?
可能是越老的版本速度越快,試試2003版看看
另外有辦法像之前將匯入資料顯示在EXCEL以便逐行執行時可以看出EXCEL如何變化，如此速度更慢了.

[attach]18182[/attach]

Option Explicit
Sub 集保戶股權_WEB_製圖()
Dim WB As Workbook, Rng As Range
Dim Ar(), A, i As Integer, strDate As String, stkno As String, Qur As String
With CreateObject("InternetExplorer.Application")
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
Set A = .document.All.tags("option") '資料日期的內容
ReDim Ar(A.Length - 1)
For i = 0 To A.Length - 1
Ar(i) = A(i).innerHTML
Next
.Quit
End With
Set WB = Workbooks.Add
With WB
.Sheets(1).Name = "圖表"
.Sheets(2).Name = "資料庫"
End With
stkno = InputBox("輸入股票代號", "股票代號", 2317) '
If stkno = "" Or Len(stkno) <> 4 Or Val(stkno) = 0 Then MsgBox "股票代號"
For i = 0 To UBound(Ar)
strDate = Ar(i) '導入月份
Qur = "http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE=" & strDate & "&SqlMethod=StockNo&StockNo=" & stkno & "&StockName=&sub=%ACd%B8%DF" '
With WB.Sheets(3)
If .QueryTables.Count = 0 Then
.QueryTables.Add "URL;" & Qur, .[A1]
Else
.QueryTables(1).Connection = "URL;" & Qur
End If
With .QueryTables(1)
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,7,8"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
If Application.Count(.ResultRange) = 0 Then
MsgBox "股票代號 " & stkno & " 錯誤"
WB.Close , False
Exit Sub
End If
If i = 0 Then WB.Sheets(2).Cells(2, i + 1).Resize(15) = .ResultRange.Range("B6").Resize(15).Value
WB.Sheets(2).Cells(1, i + 2) = Mid(.ResultRange.Range("A3"), 6)
WB.Sheets(2).Cells(2, i + 2).Resize(15) = .ResultRange.Range("E6").Resize(15).Value
End With
End With
Next
With WB
Set Rng = .Sheets(2).UsedRange
With .Sheets(1)
With .ChartObjects.Add(.[B3].Left, .[B3].Top, .[B3].Resize(, 15).Width, .[B3].Resize(25).Height).Chart
.ChartType = xlLineMarkers
.SetSourceData Rng, xlRows
.SeriesCollection(13).AxisGroup = 2
.HasTitle = True
.ChartTitle.Characters.Text = WB.Sheets(3).[A1]
.PlotArea.Interior.ColorIndex = 23
End With
End With
.Activate
End With
End Sub

複製代碼

作者: smart3135 時間: 2014-4-28 19:14

回復 40# GBKEE
版主您好，剛剛將電腦關閉後重新開啟後再重新執行VBA，結果很不錯，一個平均一秒多，可能之前我在執行VBA時開啟太多其他軟體了
[attach]18183[/attach]
這個是擷取年成交資訊，還有一個月成交資訊，因為月成交資訊是要點月份來選擇，我會先自己做看看，不行的話會再來向您討教
另外您附上的集保資料我還沒試，晚上會利用時間來試試，不過我有稍微瞄了一下，有看到INPUT BOX，因為我是要用迴圈連續擷取資料
不是要用INPUT BOX輸入代碼來擷取資料，也不需要附檔的圖，只需要文字檔內容即，不知道我是否解讀錯誤，會利用時間了解看看，再次感謝您！

作者: smart3135 時間: 2014-4-29 11:17

回復 38# GBKEE
GBKEE版主早安，我在抓上市個股年成交資訊又遇到問題了，原本是想利用您在37#的抓取上櫃年成交的程式碼來修改，但卻出錯，能請您再幫忙看一下嗎？
另外因為希望將匯入資料的EXCEL表格做一些修改再存入txt，所以我也有用先前抓其他資料的VBA來測試，但因為先前連結的網站是國泰證券，需要的資料只要將
最後的個股代碼設定成迴圈變數，就能將資料一個一個擷取下來，但上市年成交資訊的網頁不是這樣的格式，所以不清楚該怎麼做迴圈設定擷取資訊
請您再指點一下，如果可以的話，希望兩種都能學，附上兩個EXCEL VBA以及連結的資訊
[attach]18190[/attach]

"URL;https://djinfo.cathaysec.com.tw/Z/ZC/ZCC/ZCC.DJHTM?A=2330" >>>>>>>>>這是先前利用國泰證券做的連結網址，只要將最後改成迴圈變數就可以了

"URL;http://www.twse.com.tw/ch/trading/exchange/FMNPTK/genpage/Report201404/2330_F3_1_11.php?STK_NO=2330&myear=2014&mmon=04"
這是證交所上市個股2330的年成交資訊連結，不知道有沒有辦法用迴圈變數做連結

"URL;http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php" >>>>>>>>>>>>>>這是證交所上市個股年成交資訊首頁

這張圖就是想要抓的表格，上面有提到希望能先匯到EXCEL再存到文字檔就是希望年的順序可以反過來，也就是越新的年度排越上面，另外資料在匯入EXCEL後會將
(元,股)也變成一列，這一列也希望能刪除
[attach]18191[/attach]

作者: GBKEE 時間: 2014-4-30 10:27

本帖最後由 GBKEE 於 2014-4-30 10:30 編輯

回復 42# smart3135
WEB 查詢請版上有許多討論可搜尋 http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php 這字串
上市與上櫃網頁的建置不同

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"
.Visible = True '顯示ie
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上市年成交資訊()
Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
Set fs = CreateObject("Scripting.FileSystemObject")
IE_URL = "http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php"
t = Time
Application.DisplayStatusBar = True
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
'你已將上市的股票代號,在Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
Sheets(1).Activate
For Each E In Rng
With IE
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementbyid("STK_NO")
A.Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
With Sheets(1)
.Cells.Clear
For i = 1 To A(7).Rows.Length - 1
For C = 0 To A(7).Rows(i).Cells.Length - 1
.Cells(i, C + 1) = A(7).Rows(i).Cells(C).innertext
Next
Next
.UsedRange.Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=True '排序:xlDescending ( 由大至小 )
Maketxt xFile, .UsedRange
End With
ii = ii + 1
End With
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔"
Next
IE.Quit
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上市年成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub Maketxt(xF As String, Q As Range) '*** Q As Range ****
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows '修改這 Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

作者: smart3135 時間: 2014-5-1 20:30

回復 43# GBKEE
不好意思，GBKEE版主，請問是搜尋 http://www.twse.com.tw/ch/trading/exchange/FMNPTK/FMNPTKMAIN.php這字串嗎？
因為我在版上搜索這字串是查無結果的，所以想跟您確認一下，我也想好好學習網頁建置不同上的差別在哪？謝謝您！

作者: smart3135 時間: 2014-5-2 05:12

回復 43# GBKEE
哈囉！GBKEE版主，又來向您討教囉！關於在43#的程式碼在sheet(3)的A欄套用上市個股代號後是可行的，但若我想將網址改成月成交資訊
會多了一個"年"查詢欄，又該如何設定"年"的查詢欄位可以多查幾年呢？例如首頁是直接跳出103年，再輸入股票代碼即可查詢，我想將102年、101年的資料
也一起匯入，應該怎麼做變化呢？我想關鍵是不是在以下的程式碼，因為對內容的語法不太了解，所以想再來請教您一下！
我若直接將月成交資訊的網址帶入，只能匯入103年的資料，不知道是不是各年度的月成交資訊能像股票代碼一樣在sheet(3)的某欄位輸入當成迴圈
就能匯入需要的資料，例如我想要103、102、101、100年的月成交資訊，就在sheet(3)的B欄從上往下key入，再做一些程式碼的變更就能讓程式去依照
sheet(3)的B欄輸入的年份匯入月成交資訊，不知這樣的想法對不對，再請您指點一番！謝謝！
　　　Do While .Busy Or .ReadyState <> 4: Loop
         Set A = .Document.getelementbyid("STK_NO")
         A.Value = E
         .Document.getelementSbyNAME("login_btn")(0).Click  '按下查詢
         Do While .Busy Or .ReadyState <> 4: Loop
         Set A = .Document.getelementsbytagname("TABLE")

上櫃月成交資訊
[attach]18199[/attach]

上市月成交資訊
[attach]18200[/attach]

作者: smart3135 時間: 2014-5-4 06:02

回復 38# GBKEE
GBKEE版主您好，又來向您討教了，因為先前不懂為什麼查詢上市與上櫃年成交資訊的VBA程式碼中分別有"STK_NO"與"input stock code"，之後才想到是要去找網頁原紿碼
雖然大部分都看不懂，不過確實是分別在上市與上櫃年成交資訊的網頁原始碼中找到上述兩個字串，我想這應該是必定要寫在VBA中的關鍵字串，後來去查了一下上櫃的月成交資訊
有看到多出日期欄的字串，測試了將字串寫入VBA，但卻會出錯，嘗試多次變更仍無法順利執行，不知該如何將這些字串正確地寫入VBA，當然上市的月成交資訊
測試結果也和上櫃的一樣，都是無功而返，所以只能再度叨擾您了，懇請您再次賜教，感謝！
[attach]18205[/attach]

上櫃年成交資訊
[attach]18203[/attach]

上櫃月成交資訊
[attach]18204[/attach]

作者: GBKEE 時間: 2014-5-4 15:51

回復 46# smart3135

For Each E In Rng
For Each X In Rng1
With IE
'http://forum.twbts.com/viewthread.php?tid=8111 chrom 中可查看元素的結構
'<select name="yy" class="input-select ui-corner-all" id="y_date1" onchange="query()">
'<option value="1996">85</option><option value="1997">86</option><option value="1998">87</option>
Set B = .document.getelementsbytagname("select")("YY")
B.Value = X
Set A = .document.getelementbyid("input_stock_code")
A.Value = E

複製代碼

作者: smart3135 時間: 2014-5-5 05:57

回復 47# GBKEE
感謝版主耐心的回答，看了文章之後，大概了解了相對引數的關鍵字，也有試著將相對引數"select"和"yy"代入，結果是可行的
不過有點問題：
1.在迴圈執行程式時是會依照我在sheet(3) B欄輸入的年份匯入文字檔，不過下一年份的資料又會覆蓋原來的文字檔內容
例如我在sheet(3) B欄輸入的年份是2014、2013、2012，結果2014的寫完後再寫下一筆的2013就會把原來寫入的2014覆蓋掉
不知道能不能將三年的資料都寫入文字檔？
2.年份迴圈是否只能利用像個股代號一樣在sheet(3) 某欄輸入想要擷取的年份資料，能不能直接寫入VBA中呢？
3.寫入的文字檔是從開始有數字資料時寫起，不知道能不能由最上方個股代號那一列開始寫入，也就是文字檔中會看得到個股代號
4.因為這個VBA程式是直接將資料寫入文字檔，無法看到資料匯入EXCEL的動作，不知道能不能做日期排序
例如寫入的第一年份資料由上到下是103年1月份到103年5月份，不知道能不能將5月份寫到最上方
我想問題會這麼多，應該是我VBA基礎還沒打好就急於學習更進階的東西，看來我可能得多看些書、文章、影片充實自己的VBA基礎，很感謝版主連日來不厭其煩的回答！
[attach]18206[/attach]
[attach]18207[/attach]

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
' .Visible = True '不顯示ie
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃月成交資訊()
Dim E, X As Range, xPath As String, xFile As String, A, B As Object, fs As Object, F As Object, IE_URL As String
Dim i As Integer, ii As Integer, t As Date, AR(), Rng, Rng1 As Range, r, C, S
Set fs = CreateObject("Scripting.FileSystemObject")
IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
t = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
For Each X In Rng1
With IE
Set B = .document.getelementsbytagname("select")("yy")
B.Value = X
Set A = .document.getelementbyid("input_stock_code")
A.Value = E
A.ParentNode.submit
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
With fs.CreateTextFile(xFile, True)
For i = 1 To A(2).Rows.Length - 1
S = ""
For C = 0 To A(2).Rows(i).Cells.Length - 1
S = S & A(2).Rows(i).Cells(C).innertext & vbTab
Next C
.WriteLine S
Next i
.Close
End With
ii = ii + 1
End With
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next X
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18208[/attach]

作者: GBKEE 時間: 2014-5-7 17:04

回復 48# smart3135

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "G:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
Sheets(1).UsedRange.Clear '下載資料置於此工作表,變換股票時:清空
For Each X In Rng1
With IE
.document.getElementsByTagName("select")("yy").Value = X
With .document.getelementbyid("input_stock_code")
.Value = E
.ParentNode.submit
End With
Do While .Busy Or .readyState <> 4: Loop
If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
ar = Array(0, 2)
Else
ar = Array(2)
End If
For Each Ea In ar
Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
Next
ii = ii + 1
End With
Next X
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
.PasteSpecial Format:="Unicode 文字"
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Q.Range("C1") = ""
Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-12 00:04

回復 49# GBKEE
感謝GBKEE版主，49#程式碼我研究了幾天，不過還是太深奧了，有看沒有很懂，但實際上執行結果是成功的，有試著依樣畫葫蘆，將上市的網頁連結及相關引數帶入程式碼試著擷取資料
但在跑到 .ParentNode.submit會出現沒有使用權限，因為不懂這段程式碼的意思，能請您再幫忙一下嗎？
另外不知道在49#的執行結果中，有沒有辦法將月份越新的往上排序呢？再麻煩您一下囉！感謝！
例如：程式執行結果為
103年1月
103年2月
103年3月
103年4月

希望結果為
103年4月
103年3月
103年2月
103年1月

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.twse.com.tw/ch/trading/exchange/FMSRFK/FMSRFKMAIN.php"
' .Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上市月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "G:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
Sheets(1).UsedRange.Clear '下載資料置於此工作表,變換股票時:清空
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("myear").Value = X
With .Document.getelementbyid("STK_NO")
.Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
.ParentNode.submit
End With
Do While .Busy Or .readyState <> 4: Loop
If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
ar = Array(0, 2)
Else
ar = Array(2)
End If
For Each Ea In ar
Ep .Document.getElementsByTagName("TABLE")(Ea).outerHTML
Next
ii = ii + 1
End With
Next X
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
.PasteSpecial Format:="Unicode 文字"
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Q.Range("C1") = ""
Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18259[/attach]

作者: GBKEE 時間: 2014-5-15 16:21

回復 50# smart3135

但在跑到 .ParentNode.submit會出現沒有使用權限，因為不懂這段程式碼的意思，能請您再幫忙一下嗎？
希望結果為
103年4月
103年3月
103年2月
103年1月

上市,上櫃的網頁建置不一樣
試試看

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.twse.com.tw/ch/trading/exchange/FMSRFK/FMSRFKMAIN.php"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上市月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("myear").Value = X
With .Document.getelementbyid("STK_NO")
.Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
End With
Do While .Busy Or .readyState <> 4: Loop
Ep .Document.getElementsByTagName("TABLE")(7).outerHTML
End With
Next X
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
With .Range("a" & .Rows.Count).End(xlUp)
If .Row = 1 Then
Set Rng = .Cells
Else
Set Rng = .Offset(1)
End If
Rng.Select
.Parent.PasteSpecial Format:="Unicode 文字"
Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
'Sort :資料排序
Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
If .Row = 1 Then
.Range("A2").EntireRow.Delete
Else
.Range("A2:A4").EntireRow.Delete
End If
End With
End With
End With
Exit Sub
ER:
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
Q.Cells(1) = Code & " 月成交資訊" '加入股票代號
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

作者: smart3135 時間: 2014-5-16 08:28

回復 51# GBKEE
感謝GBKEE版主，這些程式碼又讓我學到很多，我也試著將上櫃資料自行排序，試了許久，終於成功了
不過這個上市在寫入文字檔的程式碼中有一些不太了解，想再向您請益：
1.和市櫃不同的地方是多了一個Code，而這個Code會直接代入E的代號，想請問這個Code是什麼？
2.在 [Q.Cells(1) = Code & " 月成交資訊" '加入股票代號]這段程式碼的結果會變成[股票代號&月成交資訊]，因為我想除了連股票代號之外，連股票名稱也能顯示
舉例來說：跑第一檔股票時結果會是"1101月成交資訊"，我想要的結果是"1101亞泥月成交資訊"，我有試著用原來A1儲存格保留的"103年1101亞泥月成交資訊"
來做修改，有用mid函數，也有用replce，並將[Q.Cells(1) = Code & " 月成交資訊" '加入股票代號]用註解跳過，但只要這段跳過就會在fs.WriteLine C出錯
如果不跳過，在這裡加入其他程式碼一樣會在fs.WriteLine C出錯，不清楚為何會這樣？

原來的程式碼

Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
Q.Cells(1) = Code & " 月成交資訊" '加入股票代號
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

我自己修改的程式碼(會出錯)

Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant, A As String, B As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
A = Q.Cells(1)
B = Mid(A, 5, 15)
Q.Cells(1) = B
' Q.Cells(1) = Code & " 月成交資訊" '加入股票代號
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: GBKEE 時間: 2014-5-16 15:57

回復 52# smart3135
Q.Cells(1) 有不可見字元如圖,會造成程式碼的錯誤,所以變通一下

Q.Cells(1) = Code & " 月成交資訊" '加入股票代號

複製代碼

[attach]18297[/attach]

作者: smart3135 時間: 2014-5-16 19:09

回復 53# GBKEE
版主您好，不好意思，請問一下加了a=Q.Cells(1)有什麼不同呢?雖然執行時不會出錯，不過結果還是沒變，因為執行到下面，輸出的結果還是Q.Cells(1) = Code & "月成交資訊"
我試著再修改了一下，不過還是如之前會出錯，不知您說的變通是指？？？？？

Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Dim A As String, B As String
A = Q.Cells(1)
' B = Mid(A, 9, 20)　　'這段程式碼加入的話就會出錯,用註解跳過則不會出錯,但這段程式碼是要擷取正確文字
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
Q.Cells(1) = Code & B '加入股票代號
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-17 13:38

回復 51# GBKEE
不好意思，GBKEE版主，又發現一個比較大的問題了，我想要的資料是近三年的月成交資料，可是有些個股是近1-2年才上市櫃的，所以在上市網頁輸入時會出現查無
而在上櫃網頁則是只會出現上櫃後開始的月成交資料，當查到上市櫃前的年份就會出現查無，如果讓VBA直接執行的話，執行到上市櫃不到三年的個股代號就會出錯
還會有無窮迴圈的狀況，不知道有沒有辦法加入其他程式碼來避免這種錯誤？
舉例來說：如果個股只有上市櫃不到一年、或一年到兩年，能不能只擷取該個股有的資料，當遇到查無的年份就結束該個股的資料擷取，跳到下一個股
附件是我將Sheet(3)代入一些上市櫃不到三年的個股代號會出錯的EXCEL，再請您指導一下，謝謝！

[attach]18308[/attach]

作者: GBKEE 時間: 2014-5-17 17:29

回復 55# smart3135

加了a=Q.Cells(1)有什麼不同呢?雖然執行時不會出錯，不過結果還是沒變，

加了a=Q.Cells(1),只是為了顯示於圖示:區域變數視窗中的不可見字元

Sub 上市月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("myear").Value = X
With .Document.getelementbyid("STK_NO")
.Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
End With
Do While .Busy Or .readyState <> 4: Loop
If .Document.getElementsByTagName("TABLE")(7).Rows.Length > 1 Then
Ep .Document.getElementsByTagName("TABLE")(7).outerHTML
Else
GoTo Nn
End If
End With
Next X
Nn:
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub

複製代碼

Option Explicit
Dim IE As Object
Sub IE_Application()
If Not IE Is Nothing Then IE.Quit '當查到上櫃的年份就會出現查無,此IE無法再度查詢,關閉它
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st44.php"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, AR(), ii As Integer, Msg As Boolean
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
Application.StatusBar = " "
For Each E In Rng
If Msg = False Then IE_Application '當查到上櫃的年份就會出現查無,重開IE
Sheets(1).UsedRange.Clear '下載資料置於此工作表,變換股票時:清空
For Each X In Rng1
With IE
.document.getElementsByTagName("select")("yy").Value = X
Do While .Busy Or .readyState <> 4: Loop
With .document.getelementbyid("input_stock_code")
.Value = E
.ParentNode.submit
End With
Do While .Busy Or .readyState <> 4: Loop
If InStr(.document.getElementsByTagName("TABLE")(0).innerHTML, "查無該筆資料") = 0 Then
Msg = True
If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
AR = Array(0, 2)
Else
AR = Array(2)
End If
For Each Ea In AR
Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
Next
Else
Msg = False '上櫃的年份就會出現查無
GoTo NN
End If
ii = ii + 1
End With
Next X
NN:
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii / 3 & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃月成交 " & ii / 3 & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Q.Range("C1") = ""
Q.Range("A1") = Q.Range("B1") & " " & "月成交資料"
Q.Range("B1") = ""
Q.Range("a4", Q.Range("a4").End(xlDown)).Replace "年", ""
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Q.Rows(3).Delete '上櫃月成交資料當月還未結束時就會有資料了,所以要將還沒結束的月份刪除
'是Q.Rows(3)不 Rows(4)
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-19 12:30

回復 53# GBKEE
GBKEE版主您好，這幾天終於弄懂了為什麼這個程式碼會出錯了，原來您說的不可見字元是Ｑ.Cells(1)文字中內含的問號
我是著用以下方法讓它不會出錯，也能取得個股名稱一起代入，不過下面的方法只能適用個股名稱是兩個字的，如果遇上三個字的還是會出錯
不知是否還有其他變通方式？再請您指點一下，謝謝！
另外還想請問您Code As String的Code是怎麼帶出個股編號的？因為我在這個程式中似乎找不到和Code有相關的程式碼能取得個股編號，再麻煩您解惑一下，謝謝！

Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant, A As String, B As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
A = Q.Cells(1)
B = Mid(A, 11, 2)
Q.Cells(1) = Code & B & " 月成交資訊" '加入股票代號
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-19 12:53

回復 53# GBKEE
抱歉，更正一下，上一篇回覆的內容有點錯誤
如果遇上三個字的還是會出錯改成如果遇上三個字的個股名稱就只能擷取到兩個字

作者: smart3135 時間: 2014-5-19 13:25

回復 40# GBKEE
抱歉，先前有個問題一直忘了問您，您在40#中回覆的程式碼確實是可以製圖及取得集保戶近一年資料，不過和我想要的格式不大相同
在您後面指導如何利用檢視網頁原始碼取得關鍵引數後，我有試著利用取得上市月資料的程式碼將集保戶網頁及相關引數代入，但在中途就會出錯
不大清楚問題出在什麼地方，附上程式碼以及我想要完成的文字檔格式，再麻煩您教導一下，感謝！

集保戶網頁
[attach]18315[/attach]

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 集保()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("SCA_DATE").Value = X
With .Document.getelementbyid("StockNo")
.Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
End With
Do While .Busy Or .readyState <> 4: Loop
If .Document.getElementsByTagName("TABLE")(7).Rows.Length > 1 Then
Ep .Document.getElementsByTagName("TABLE")(7).outerHTML
Else
GoTo Nn
End If
End With
Next X
Nn:
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
With .Range("a" & .Rows.Count).End(xlUp)
If .Row = 1 Then
Set Rng = .Cells
Else
Set Rng = .Offset(1)
End If
Rng.Select
.Parent.PasteSpecial Format:="Unicode 文字"
Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
'Sort :資料排序
Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
If .Row = 1 Then
.Range("A2").EntireRow.Delete
Else
.Range("A2:A4").EntireRow.Delete
End If
End With
End With
End With
Exit Sub
ER:
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

[attach]18316[/attach]

作者: GBKEE 時間: 2014-5-19 16:18

本帖最後由 GBKEE 於 2014-5-20 16:04 編輯

回復 59# smart3135

Option Explicit
Dim IE As Object, A As Integer
Sub IE_Application()
Dim i As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期總個數
A = .document.getelementsByTagName("select")("SCA_DATE").Length - 1
End With
End Sub
Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
'End With
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-19 19:06

回復 60# GBKEE
版主抱歉，請問一下，我將您提供的程式碼代入後出錯位置及出錯訊息仍和之前一樣，能麻煩您再幫忙看一下嗎？感恩！
[attach]18317[/attach]

Option Explicit
Dim IE As Object, A As Integer
Sub IE_Application()
Dim I As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期總個數
A = .document.getelementsByTagName("select")("SCA_DATE").Length - 1
End With
End Sub
Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = A - 1 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
'End With
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
.PasteSpecial Format:="Unicode 文字"
' Set Rng = Selection
' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim AR, I As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For I = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(I)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

作者: GBKEE 時間: 2014-5-20 15:59

本帖最後由 GBKEE 於 2014-5-20 16:01 編輯

回復 61# smart3135
該我說抱歉

31. For x = A - 1 To A

複製代碼

需更正

For x = 0 To A

複製代碼

請在指出哪裡錯誤.

作者: smart3135 時間: 2014-5-21 09:28

回復 62# GBKEE
版主您好，不好意思，我有試著將For x = A - 1 To A 改成For x = 0 To A，不過出錯訊息和出錯位置仍相同，能不能再麻煩您測試一下呢？
另外在更之前的上櫃年成交資料，就是用比較舊的寫法，不貼上EXCEL直接寫入TXT的程式碼，雖然有資料，不過最上方少了個股代號和名稱，不知這部分能不能
也擷取到資料並寫入TXT？或是是有可以先貼到EXCEL再寫入TXT的方法？再麻煩您了！

Option Explicit
Dim IE As Object, A As Integer
Sub IE_Application()
Dim I As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期總個數
A = .document.getelementsByTagName("select")("SCA_DATE").Length - 1
End With
End Sub
Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
'End With
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
.PasteSpecial Format:="Unicode 文字"
' Set Rng = Selection
' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim AR, I As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For I = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(I)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
.Visible = True '不顯示ie
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃年成交資訊()
Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
Set fs = CreateObject("Scripting.FileSystemObject")
IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
t = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With IE
Set A = .Document.getelementbyid("input_stock_code")
A.Value = E
A.ParentNode.submit
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\HPY.txt"
MkDir_Sub xFile
With fs.CreateTextFile(xFile, True)
For i = 1 To A(2).Rows.Length - 1
S = ""
For C = 0 To A(2).Rows(i).Cells.Length - 1
S = S & A(2).Rows(i).Cells(C).innertext & vbTab
Next
.WriteLine S
Next
.Close
End With
ii = ii + 1
End With
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔"
Next
IE.Quit
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As QueryTable) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.ResultRange.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18322[/attach]

作者: GBKEE 時間: 2014-5-21 16:11

回復 63# smart3135

成For x = 0 To A，不過出錯訊息和出錯位置仍相同

我測試沒出錯,請說明出錯訊息和出錯位置.

With fs.CreateTextFile(xFile, True)
S = Split(A(0).innertext, ")")(1)
.WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.
For i = 1 To A(2).Rows.Length - 1
S = ""
For C = 0 To A(2).Rows(i).Cells.Length - 1
S = S & A(2).Rows(i).Cells(C).innertext & vbTab
Next
.WriteLine S
Next
.Close
End With

複製代碼

作者: smart3135 時間: 2014-5-21 20:17

回復 64# GBKEE
版主您好，集保程序我有試著再執行一次，結果還是一樣，出錯訊息如圖：
[attach]18326[/attach]

另外您提供的程式碼我有加入上櫃年成交中，最上方是有寫入了，不過是寫入空白資料，不是股票代號和名稱，能麻煩您再看一下嗎？

Sub 上櫃年成交資訊()
Dim E As Range, xPath As String, xFile As String, A As Object, fs As Object, F As Object, IE_URL As String
Dim i As Integer, ii As Integer, t As Date, AR(), Rng As Range, r, C, S
Set fs = CreateObject("Scripting.FileSystemObject")
IE_URL = "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
t = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With IE
Set A = .Document.getelementbyid("input_stock_code")
A.Value = E
A.ParentNode.submit
Do While .Busy Or .ReadyState <> 4: Loop
Set A = .Document.getelementsbytagname("TABLE")
xFile = xPath & "\" & E & "\HPY.txt"
MkDir_Sub xFile
With fs.CreateTextFile(xFile, True)
S = Split(A(0).innertext, ")")(1)
.WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.
For i = 1 To A(2).Rows.Length - 1
S = ""
For C = 0 To A(2).Rows(i).Cells.Length - 1
S = S & A(2).Rows(i).Cells(C).innertext & vbTab
Next
.WriteLine S
Next
.Close
End With
ii = ii + 1
End With
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔"
Next
IE.Quit
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub

複製代碼

[attach]18327[/attach]

作者: smart3135 時間: 2014-5-22 09:34

本帖最後由 smart3135 於 2014-5-22 09:35 編輯

回復 64# GBKEE
版主您好，今天利用上櫃月成交資料的程式碼來做了一些修正，已經可以順利擷取上櫃年成交資料了，只是還有一些小問題：
1.多餘的語法該刪除的我應該都刪除了，不確定有沒有多餘不必要的語法沒被刪除
2.在擷取資料貼到EXCEL後，日期的部分會變成文字，請見附圖，不過網頁顯示的只是單純的日期
舉例來說：網頁顯示的表格是4/17，但匯入EXCEL後就會變成4月17日，而寫入文字檔時則變成2014/4/17
我有試著在匯入EXCEL之前將日期欄位的儲存格格式先設定成文字，不過貼上EXCEL後還是會被修改格式
我希望寫入文字檔的日期資料只要月日就好，也就是4/17，不知道這部分有沒有辦法修改？
另外如65#回覆，集保戶資料的問題還是未能解決，再麻煩您幫忙看一下囉！感謝！
[attach]18329[/attach]
[attach]18330[/attach]

Option Explicit
Dim IE As Object
Sub IE_Application()
If Not IE Is Nothing Then IE.Quit '當查到上櫃的年份就會出現查無,此IE無法再度查詢,關閉它
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.gretai.org.tw/ch/stock/statistics/monthly/st42.php"
' .Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上櫃年成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, AR(), ii As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "G:\財報資料"
IE_Application
Application.StatusBar = " "
For Each E In Rng
Sheets(1).UsedRange.Clear '下載資料置於此工作表,變換股票時:清空
With IE
With .document.getelementbyid("input_stock_code")
.Value = E
.ParentNode.submit
End With
Do While .Busy Or .readyState <> 4: Loop
If Application.Count(Sheets(1).UsedRange) = 0 Then '此工作表清空時:下載第一年度時
AR = Array(0, 2)
' Else
' AR = Array(2)
End If
For Each Ea In AR
Ep .document.getElementsByTagName("TABLE")(Ea).outerHTML
Next
End With
ii = ii + 1
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃" & E & "年成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上櫃年成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Select
If .Range("a1") <> "" Then .Range("a" & .Rows.Count).End(xlUp).Offset(1).Select
.PasteSpecial Format:="Unicode 文字"
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub MkDir_Sub(S As String)
Dim AR, i As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For i = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Q.Range("C1").Clear
Q.Range("A1") = Q.Range("B1") & " " & "年成交資料"
Q.Range("B1").Clear
Q.Rows(2).Delete
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

[attach]18331[/attach]

作者: GBKEE 時間: 2014-5-22 16:04 標題: 啟

本帖最後由 GBKEE 於 2014-5-22 16:28 編輯

回復 66# smart3135

S = Split(A(0).innertext, ")")(1)
.WriteLine Split(S, vbLf)(0) '最上方加上個股代號和名稱了.

複製代碼

集保程序我有試著再執行一次，結果還是一樣，出錯訊息如圖

2003版
確定可以寫入股票代號及名稱
集保程序,一樣確定沒有出現錯誤.
你是在2007中執行嗎?(請有2007版測試一下)

希望寫入文字檔的日期資料只要月日就好，也就是4/17

Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant, R As Range
With Q
.Range("C1").Clear
.Range("A1") = Q.Range("B1") & " " & "年成交資料"
.Range("B1").Clear
.Rows(2).Delete
.Range("H:H,F:F").NumberFormatLocal = "m/d;@"
.EntireColumn.AutoFit
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = ""
For Each R In E.Cells
C = C & IIf(C <> "", vbTab, "") & R.Text
'C = Application.Transpose(Application.Transpose(E.Value))
'C = Join(C, vbTab)
Next
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-22 19:22

回復 67# GBKEE
版主您好，因為我有雙系統，一個是WIN7+2007，一個是XP+2003，我平常都是開WIN7的，經你提醒，今天試著用2003跑一次集保程序
結果真的可以執行，不會出錯，但在2007卻會出錯，這部分可能還要再研究一下為什麼會這樣
另外寫入日期部分經帶入您的程式碼後已可正常寫入日期，再次感謝您大力協助，謝謝您！

作者: smart3135 時間: 2014-5-23 11:11

本帖最後由 smart3135 於 2014-5-23 11:13 編輯

回復 67# GBKEE
版主您好，經過今天早上不斷使用2003版測試，終於做出我想要的輸出文字檔結果，不過還是有些問題會發生，先附上程式碼與附檔
[attach]18346[/attach]
這裡是完整的程式碼

Option Explicit
Dim IE As Object, A As Integer
Sub IE_Application()
Dim I As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
' .Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期總個數
A = .document.getelementsByTagName("select")("SCA_DATE").Length - 1
End With
End Sub
Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer, F As String, H As String, J As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "E:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
With IE
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(5).outerHTML
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(6).outerHTML
End With
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
With Sheets(1)
F = .Range("a3")
J = Len(F)
If J >= 19 Then
H = Mid(F, 1, 3)
Else
H = Mid(F, 1, 2)
End If
.Range("a1") = E & "-" & H & " " & "集保戶股權分散表"
.Rows("2:4").Delete
End With
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange, E.Value
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
'xFile(第一個引數), Sheets(1).Range("A1").CurrentRegion(第二個引數),E.Value(第三個引數)
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .Rows.Count).End(xlUp).Select
Set Rng = Selection
If Rng = 15 Then
Rng.Offset(3).Select
Else
Rng.Offset(2).Select
End If
.PasteSpecial Format:="Unicode 文字"
' If Selection = "" Then Selection.Offset(1).Select
' Set Rng = Selection
' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
'***想請問您Code As String的Code是怎麼帶出個股編號的 ****
' xF(接收的引數名稱) As String(字串型態), Q As Range(Range物件型態), Code As String(字串型態)
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim AR, I As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For I = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(I)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

因為我要的文字檔除了個股代號和名稱之外，還有日期也要一併寫入，所以我就自己加了以下這些東西

With IE
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(5).outerHTML
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(6).outerHTML
End With
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.getElementById("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
'這裡的查詢是<INPUT TYPE="submit" VALUE="查詢" name="sub">
Do While .Busy Or .readyState <> 4: Loop
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With

複製代碼

1.首先第一段是為了要擷取("TABLE")(5)才能匯入個股名稱，所以我加了這些語法，由於個股名稱只需要擷取一次
所以將這段語法寫在x迴圈之外，但不知道這樣的語法正不正確
2.因為要擷取的日期是在("TABLE")(6)，所以將這段也寫入，就只是複製("TABLE")(7)的改成6而已，也不確定這樣寫到底正不正確
3.以上程式碼在2003使用F8逐行執行時是可以正常的，但使用F5連續執行時有時會出錯，不然就是("TABLE")(5)和("TABLE")(6)會有資料重覆或者漏抓
以("TABLE")(6)抓到的日期來說，會抓到兩個一樣的日期(日期錯誤)，但資料內容的("TABLE")(7)卻是不同的(內容正確)，也就是日期和資料內容對不上
不知道是不和我的語法有問題

另外先前向您提過，用2007執行上述程式碼時會出錯，出錯代碼為"424"，出錯訊息為"此處需要物件"，我有點說明進去看，但真的看不太懂
我將說明內容存成PDF一起放在附件中，可以的話再麻煩您看看是不是可以找出為什麼這個程式碼沒法在2007執行的原因，再次感謝您！

作者: GBKEE 時間: 2014-5-23 15:59

回復 69# smart3135

Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer, F As String, H As String, J As Integer, StockNo As Object
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
Set StockNo = .document.getElementById("StockNo")
'出錯代碼為"424"，出錯訊息為"此處需要物件",就給它設為物件,2007版試試看是否可行
StockNo.Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
Do While .Busy Or .readyState <> 4: Loop
If x = 0 Then Sheets(1).Cells(1) = .document.getelementsByTagName("TABLE")(5).INNERTEXT
Ep .document.getelementsByTagName("TABLE")(6).INNERTEXT
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, E As Shape, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
.Range("a" & .UsedRange.Rows.Count + 1).Select
Set Rng = Selection
.PasteSpecial Format:="Unicode 文字"
End With
End With
Exit Sub
ER:
FormDLL = "FM20.DLL"
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\" & FormDLL
Resume
End Sub

複製代碼

作者: smart3135 時間: 2014-5-23 19:14

回復 70# GBKEE
哈囉！版主您好，再度將您修正過後都程式碼代入之後仍是在相同位置出現"424"的錯誤，由於您的EXCEL版本並非2007，所以也沒辦法一一測試我的錯誤
看來這個問題似乎需要再慢慢研究
我用2003執行是正常的，不過在執行的過程中，我發現抓下來的資料會有一些問題
[attach]18352[/attach]
如圖，有些日期的資料是重覆的，有些日期的資料卻漏抓，103年3月份抓了2次，103年2月卻漏抓，但這個情況只有在按下F5連續執行時才會發生
按F8逐行執行則不會，不知道為什麼會這樣？想請問兩個問題
1.這種狀況有辦法加入其他程式碼來避免嗎？
2.就我的感覺應該是F5連續執行的速度太快，以致於網頁反應不及，還來不及跳到下一筆日期就抓資料了才會出錯，不知道這樣推斷正不正確？

附上完整的文字檔，再麻煩您幫忙看看囉！感謝！
[attach]18351[/attach]

作者: smart3135 時間: 2014-5-24 12:50

回復 70# GBKEE
版主您好，我在無意中發現了可以解決錯誤的方法，也不需要再另外設物件，只要將.document.getElementById("StockNo").Value=E
改成.document.All("StockNo").Value=E就可以了，也就是getElementById改成All就可以正常執行了
只是不清楚為什麼這樣改就可以了

For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsByTagName("select")("SCA_DATE")(x).Selected = True
'這裡的資料日期需用 Select 它是有[年度月份日期]的
.document.All("StockNo").Value = E
.document.getelementsByTagName("INPUT")("sub").Click '按下查詢
Do While .Busy Or .readyState <> 4: Loop
If x = 0 Then Sheets(1).Cells(1) = .document.getelementsByTagName("TABLE")(5).INNERTEXT
Ep .document.getelementsByTagName("TABLE")(6).INNERTEXT
Ep .document.getelementsByTagName("TABLE")(7).outerHTML
End With
Next x
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
Next E

複製代碼

不過又遇到了另一個問題，就是當個股遇到沒當年度月份的資料時，就會出現查無資料的視窗，這是連續執行的結果
[attach]18356[/attach]

而當我用F8逐行執行的結果，當遇到查無年度月份資料時，就會一直在Do While .Busy Or .readyState <> 4: Loop執行無窮迴圈
請問這部分是否有辦法解決？我個人猜想應該是要修正變數A或x的程式碼，但卻不清楚該怎麼修改，只好再麻煩您幫忙看看了，謝謝！
[attach]18357[/attach]

作者: GBKEE 時間: 2014-5-25 16:16

回復 72# smart3135

Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer, F As String, H As String, j As Integer
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
IE.Visible = True '必須顯示IE ,查無資料,按下確定鍵
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsbytagname("select")("SCA_DATE")(x).Selected = True
'.document.getElementById("StockNo").Value = E 'getElementById於 2007有錯誤
.document.ALL("StockNo").Value = E 'ALL 於2007可行
.document.getelementsbytagname("INPUT")("sub").Click '按下查詢
On Error Resume Next '程式有錯誤時:繼續執行下去
Do While .Busy Or .readyState <> 4
Do
Err.Clear
'IE接收資料尚未完成 .document.getelementsbytagname("TABLE").Length 會有錯誤
If .document.getelementsbytagname("TABLE").Length <= 5 Then '查無資料
Application.SendKeys "~", True ' 按下確定鍵
GoTo Nextx
End If
Loop Until Err = 0
Loop
On Error GoTo 0 '程式有錯誤時:不處裡
If x = 0 Then Sheets(1).Cells(1) = .document.getelementsbytagname("TABLE")(5).INNERTEXT
Ep .document.getelementsbytagname("TABLE")(6).INNERTEXT
Ep .document.getelementsbytagname("TABLE")(7).outerHTML
End With
Next x
Nextx:
If Sheets(1).UsedRange.Rows.Count > 1 Then
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
End If
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub

複製代碼

作者: smart3135 時間: 2014-5-25 23:53

回復 73# GBKEE
版主您好，試著將您新增的程式碼代入，的確是可以避免錯誤的發生，但在執行程式後會變成擷取的資料不完整
例如1301的資料是從2014年5月到2013年5月，可是在擷取資料時卻沒辦法抓下完整資料，有時只抓到一個月，有時只抓到三個月
不知您是否能幫忙執行看看是否和我說的結果相同
相較於之前還未加入您在73#的程式碼，雖然當遇到查無日期會出錯，不過當有完整一年份資料日期時
抓到的資料都是完整的
我自己也有適著寫入一些程式碼，或著變換程式碼的一些先後位置，但執行結果都不理想
不知道有沒有更適合的程式碼，能避免出錯，也能讓抓到的資料是完整的，再麻煩您幫忙看看了，謝謝！
附帶一提，不會出錯的那個程式用F8逐行執行似乎可以抓到完整資料，但用F5連續執行，抓到的資料就會不完整
不知道是不是因為用連續執行的速度太快，網頁來不及反應，所以抓到的資料才不完整
[attach]18365[/attach]

作者: smart3135 時間: 2014-5-26 09:50

回復 73# GBKEE
版主，不好意思，上一篇回覆其中一個檔案有錯誤，我再重新附上
另外我花了一些時間做出了另一個版本的程式，是利用儲存格輸入日期當作迴圈，已測試可以抓資料，但有些小問題：
1.有些語法我不太懂怎麼簡化，所以可能寫的比較複雜一點
2.利用儲存格當日期迴圈的缺點，就是每個月都要更新儲存格中的日期
3.我自己寫的程式碼執行到代碼1340時還是會出錯，不過如果把第一個代碼重新設成1340開始抓資料又正常
4.因為表頭的文字會重覆抓取，但我只需要一次，所以用一列一列刪除的笨方法

這個程式寫的比較粗糙，抓資料的速度似乎也比較慢，不過確實可以達到我需要的結果，除了遇到某些代碼會卡住需要重新設定外
其他都還OK，再請您幫忙看一下是否有錯誤的地方需要修正，謝謝！
[attach]18368[/attach]

Option Explicit
Sub 集保完成()
Dim E As Range, X As Range, URL As String, xPath As String, xFile As String, rng As Range, rng1 As Range
Dim Msg As Boolean, I As Integer, t As Date, S As String, BB As String, CC As String, rng2 As Range
t = Time
URL = "URL;http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE="
BB = "&SqlMethod=StockNo&StockNo="
CC = "&sub=%ACd%B8%DF"
xPath = "D:\財報資料"
With ThisWorkbook
With .Sheets(3)
Set rng = .Range("A1", .Range("A1").End(xlDown))
Set rng1 = .Range("B1", .Range("B1").End(xlDown))
End With
' .Sheets(3).Activate '兩種寫法都可以不過第一種比較簡化所以第二種跳過
' .Sheets(3).Range("a1").Select
' Range(Selection, Selection.End(xlDown)).Select
' Set rng = Selection
'' Set rng = .Sheets(3).Range("A:A") '這裡這樣設定會變成無窮迴圈
' .Sheets(1).Activate
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
For Each E In rng
With ThisWorkbook
.Sheets(2).Cells.Clear
' .Activate
.Sheets(1).Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In rng1
With .QueryTables(1)
.Connection = URL & X & BB & E & CC
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,7,8"
On Error GoTo xlnext
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
Set rng2 = Sheets(1).UsedRange
If Sheets(2).Range("a1") = "" Then
rng2.Copy Sheets(2).Range("a" & .Rows.Count).End(xlUp)
Else
rng2.Copy Sheets(2).Range("a" & .Rows.Count).End(xlUp).Offset(2, 0)
End If
Next X
xlnext:
Sheets(2).Range("2:2,22:22,43:43,64:64,85:85,106:106,127:127,148:148,169:169,190:190,211:211,232:232,253:253").Delete
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, Sheets(2).UsedRange
' S = " " & Sheets(1).QueryTables(1).ResultRange(1)
' If Val(S) < 0 Then S = " 查無"
I = I + 1
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " " & E & "匯入" & I & "個文字檔"
Msg = False
Next E
End With
End With
MsgBox "共匯入文字檔" & I & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
End Sub
Sub MkDir_Sub(S As String)
Dim AR, I As Integer, xPath As String
If Dir(S) = "" Then
AR = Split(S, "\")
xPath = AR(0)
For I = 1 To UBound(AR) - 1
xPath = xPath & "\" & AR(I)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub

複製代碼

作者: smart3135 時間: 2014-5-26 11:45

回復 73# GBKEE
Sorry，儲存格又忘了填上資料，再附上正確檔案
[attach]18370[/attach]

作者: GBKEE 時間: 2014-5-26 17:12

本帖最後由 GBKEE 於 2014-5-26 17:15 編輯

回復 75# smart3135

Option Explicit
Sub 集保完成()
Dim E As Range, X As Range, URL As String, xPath As String, xFile As String, rng As Range, rng1 As Range
Dim Msg As Boolean, I As Integer, t As Date, S As String, BB As String, CC As String, rng2 As Range
IE_Application '更新集保戶股權分散表查詢的資料日期
t = Time
URL = "URL;http://www.tdcc.com.tw/smWeb/QryStock.jsp?SCA_DATE="
BB = "&SqlMethod=StockNo&StockNo="
CC = "&sub=%ACd%B8%DF"
xPath = "D:\財報資料"
With ThisWorkbook
With .Sheets(3)
Set rng = .Range("A1", .Range("A1").End(xlDown))
Set rng1 = .Range("B1", .Range("B1").End(xlDown))
End With
With .Sheets(1) '活頁簿的第 1 張工作表
If .QueryTables.Count = 0 Then
With .QueryTables.Add(Connection:=URL, Destination:=.Range("$A$1"))
.Refresh BackgroundQuery:=False
End With
End If
For Each E In rng
With ThisWorkbook
.Sheets(2).Cells.Clear
.Sheets(1).Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In rng1
With .QueryTables(1)
.Connection = URL & X & BB & E & CC
.PreserveFormatting = True
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
If X.Row = 1 Then
.WebTables = "6,7,8"
Else
.WebTables = "7,8"
End If
On Error GoTo xlnext
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
If Sheets(2).Range("a1") = "" Then
.ResultRange.Copy Sheets(2).Range("a" & Sheets(2).Rows.Count).End(xlUp)
Else
.ResultRange.Copy Sheets(2).Range("a" & Sheets(2).Rows.Count).End(xlUp).Offset(2, 0)
End If
End With
Next
xlnext:
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile '10#的程式 'C槽下的季損益表資料夾不需先建立
Maketxt xFile, Sheets(2).UsedRange
I = I + 1
Application.StatusBar = Application.Text(Time - t, ["MM分SS秒"]) & " " & E & "匯入" & I & "個文字檔"
Msg = False
Next E
End With
End With
MsgBox "共匯入文字檔" & I & " 費時 " & Application.Text(Time - t, ["MM分SS秒"])
End Sub
Sub Maketxt(xF As String, Q As Range) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant
'*************************
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete '刪除空白列
'*************************
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.WriteLine C
Next
fs.Close
End Sub
Private Sub IE_Application() '更新集保戶股權分散表查詢的資料日期
Dim IE As Object, A As Object, I As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期
Set A = .document.getelementsbytagname("option")
For I = 0 To A.Length - 1
ThisWorkbook.Sheets(3).Cells(I + 1, "B") = A(I).INNERTEXT
Next
.Quit
End With
End Sub

複製代碼

作者: GBKEE 時間: 2014-5-26 17:13

回復 74# smart3135

Option Explicit
Dim IE As Object, A As Integer
Sub IE_Application()
Dim I As Integer
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.tdcc.com.tw/smWeb/QryStock.jsp"
.Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'讀取集保戶股權分散表查詢的資料日期總個數
A = .document.getelementsbytagname("select")("SCA_DATE").Length - 1
End With
End Sub
Sub 集保()
Dim Rng As Range, E As Range, x As Variant, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ii As Integer, F As String, H As String, J As Integer
Dim StockNo As Object
T = Time
Application.DisplayStatusBar = True
'請將上櫃的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
xPath = "D:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For x = 0 To A
With IE
.document.getelementsbytagname("select")("SCA_DATE")(x).Selected = True
'.document.getElementById("StockNo").Value = E 'getElementById於 2007有錯誤
.document.ALL("StockNo").Value = E 'ALL 於2007可行
.document.getelementsbytagname("INPUT")("sub").Click '按下查詢
Do While .Busy Or .readyState <> 4
.document.Focus
Application.SendKeys "~", True ' 按下確定鍵
Loop
Set StockNo = Nothing
Do While StockNo Is Nothing
Set StockNo = .document.getelementsbytagname("TABLE")
Loop
With StockNo
If .Length <= 5 Then GoTo Nextx '查無資料
If x = 0 Then Sheets(1).Cells(1) = .Item(5).INNERTEXT
Ep .Item(6).INNERTEXT
Ep .Item(7).outerHTML
End With
End With
Next x
Nextx:
If Sheets(1).UsedRange.Rows.Count > 1 Then
xFile = xPath & "\" & E & "\SHD.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).UsedRange, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔"
End If
Debug.Print IE.document.getelementsbytagname("TABLE").Length
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub

複製代碼

作者: smart3135 時間: 2015-2-10 11:34

回復 smart3135
GBKEE 發表於 2014-5-26 17:13

GBKEE版主您好，去年有向您請教如何用迴圈抓取股市大量資料，幫助非常大，今年已經有新的年度資料，我想要抓取新的年度資料
但不知道為什麼去年度可以正常執行的VBA程式碼，到了今年卻會一直出錯，我嘗試新增、刪除、變更一些程式碼，但都無效
能不能請您再次幫忙看看程式碼有什麼問題嗎？感謝您！
[attach]20242[/attach]
出錯圖
[attach]20243[/attach]
[attach]20244[/attach]

作者: GBKEE 時間: 2015-2-10 17:29

回復 79# smart3135

For Each E In Rng
With IE
Do While .Busy Or .ReadyState <> 4: Loop
.Document.getelementbyid("STK_NO").Value = E
.Document.getelementSbyNAME("login_btn")(0).Click '按下查詢
Do While .Busy Or .ReadyState <> 4: Loop
.Refresh '網頁需重新整理 ,才有資料下載
Do While .Busy Or .ReadyState <> 4: Loop
Set a = .Document.getelementsbytagname("TABLE")
Do While a.Length <> 14: Loop '直到 a元素的子項目有14個
xFile = xPath & "\" & E & "\HPY.txt"

複製代碼

作者: smart3135 時間: 2015-2-11 08:32

本帖最後由 smart3135 於 2015-2-11 08:33 編輯

回復 smart3135
GBKEE 發表於 2015-2-10 17:29

版主您好，有試著套用您的程式碼，但在加入Refresh後會出現下圖錯誤
[attach]20248[/attach]

若是將Refresh註解跳過，是可以順利執行，不過有時候跑到一半的時候就不動了，似乎是在執行無限迴圈
必須要按ESC強制停止，再按偵錯就會跳到Do While .Busy Or .ReadyState <> 4: Loop這段程式碼
應該就是這段程式碼在執行無限迴圈
[attach]20249[/attach]
[attach]20250[/attach]

[attach]20251[/attach]

作者: GBKEE 時間: 2015-2-11 16:10

回復 81# smart3135

在IE8下可執行,請看看你的IE [網際網路選項]需修改什麼!!

作者: smart3135 時間: 2015-2-12 12:49

回復 smart3135

在IE8下可執行,請看看你的IE [網際網路選項]需修改什麼!!
GBKEE 發表於 2015-2-11 16:10

Hello版主，經確認之後應該是和我的系統問題有關係，因為今天重灌電腦後，再用原來的程式碼跑一次
就是最原始的那個VBA，還未加入您修改的程式碼就可以順利執行了，不過還是又跟您多學到一些了，感謝！

作者: smart3135 時間: 2017-6-14 16:07

回復 56# GBKEE
不好意思，由於今年證交所網址大改版，原本的抓資料程式碼都會出錯，有試著看網頁原始碼修改程式碼
無奈功力太淺還是沒辦法，不知道是否還有機會請版主指點一下究竟該如何修改呢？
[attach]27331[/attach]

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.twse.com.tw/ch/trading/exchange/FMSRFK/FMSRFKMAIN.php"
' .Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上市月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii, aa As Integer
T = Time
Application.DisplayStatusBar = True
'請將上市的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "F:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
MR:
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("query_year").Value = X
.Document.getelementsbyname("CO_ID")(0).Value = E
.Document.getelementsbyname("query-button")(0).Click '按下查詢
Do While .Busy Or .readyState <> 4: Loop
On Error Resume Next
If InStr(.Document.getElementsByTagName("TABLE")(3).outerHTML, "查無") Then GoTo Nn
If .Document.getElementsByTagName("TABLE")(3).Rows.Length > 1 Then
Ep .Document.getElementsByTagName("TABLE")(3).outerHTML
Else
GoTo Nn
End If
' If InStr(Selection.Cells(3, 1), "查無") Then Selection.Delete Shift:=xlUp: GoTo Nn
End With
With Sheets(1)
aa = Selection.Range("a3")
If aa = "" Then aa = Selection.Range("a1") '會出錯才加入這段
If aa + 1911 <> X Then GoTo MR
End With
Next X
Nn:
If Sheets(1).Range("a1") = "" Then GoTo KK
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 匯入上市月成交 " & E & "共" & ii & " 文字檔"
KK:
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
With .Range("a" & .Rows.Count).End(xlUp)
If .Row = 1 Then
Set Rng = .Cells
Else
Set Rng = .Offset(1)
End If
Rng.Select
.Parent.PasteSpecial Format:="Unicode 文字"
Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
With Sheets(1).Sort
.SetRange Rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sort :資料排序
' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
' If .Row = 1 Then
' .Range("A2").EntireRow.Delete
' Else
' .Range("A2:A4").EntireRow.Delete
' End If
End With
End With
End With
Exit Sub
ER:
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant, A As String, B As Integer, D As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
A = Q.Cells(1)
B = Len(A)
If B >= 25 Then
D = Mid(A, 11, 4)
Else
D = Mid(A, 11, 2)
End If
Q.Cells(1) = Code & "-" & D & "" & " 月成交資料" '加入股票代號
If Q.Cells(3, 1).Offset(1) = "" Then GoTo EE
Q.Range("a3", Q.Range("a3").End(xlDown)).Replace "年度", ""
Q.Columns(1).SpecialCells(xlCellTypeBlanks).Offset(-1).EntireRow.Delete
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
EE:
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.Write C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

作者: GBKEE 時間: 2017-6-15 15:10

本帖最後由 GBKEE 於 2017-6-15 15:14 編輯

[attach]27341[/attach]

For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("Yy").Value = X
'yy -> 年度,mm -> 月份, dd -> 日期
.Document.getelementsbyname("stockNo")(0).Value = E
'股票代碼 stockNo '**大小寫要一致**
' .Document.getelementsbyname("query-button")(0).Click '按下查詢
For Each Ea In .Document.body.all.tags("a")
If Ea.classname = "button search" Then
Ea.Click: Exit For '按下查詢
End If
Next
Do While .Busy Or .readyState <> 4: Loop
On Error Resume Next

複製代碼

回復 84# smart3135

作者: smart3135 時間: 2017-6-15 22:01

回復 85# GBKEE
不好意思，我執行後似乎會卡在圖中的迴圈，不知能否請您執行看看是否有一樣情形呢？

[attach]27344[/attach]

Option Explicit
Dim IE As Object
Sub IE_Application()
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate "http://www.twse.com.tw/ch/trading/exchange/FMSRFK/FMSRFKMAIN.php"
' .Visible = True '不顯示ie
Do While .Busy Or .readyState <> 4: DoEvents: Loop
End With
End Sub
Sub 上市月成交資訊()
Dim Rng As Range, Rng1 As Range, E As Range, X As Range, T As Date, xPath As String, xFile As String
Dim Ea As Variant, ar(), ii, aa As Integer
T = Time
Application.DisplayStatusBar = True
'請將上市的股票代號,在 Sheets(3).Range("A1")往下Key上,迴圈依這裡的股票代號匯入
Set Rng = ThisWorkbook.Sheets(3).Range("A:A")
Set Rng1 = ThisWorkbook.Sheets(3).Range("b:b")
If Application.Count(Rng) = 0 Then MsgBox "沒有股票代號": Exit Sub
If Application.Count(Rng1) = 0 Then MsgBox "沒有股票代號": Exit Sub
Set Rng = Rng.SpecialCells(xlCellTypeConstants)
Set Rng1 = Rng1.SpecialCells(xlCellTypeConstants)
xPath = "F:\財報資料"
IE_Application '
Application.StatusBar = " "
For Each E In Rng
MR:
With Sheets(1)
.Activate
.Cells.Clear '下載資料置於此工作表,變換股票時:清空
End With
For Each X In Rng1
With IE
.Document.getElementsByTagName("select")("Yy").Value = X
'yy -> 年度,mm -> 月份, dd -> 日期
.Document.getelementsbyname("stockNo")(0).Value = E
'股票代碼 stockNo '**大小寫要一致**
' .Document.getelementsbyname("query-button")(0).Click '按下查詢
For Each Ea In .Document.body.all.tags("a")
If Ea.classname = "button search" Then
Ea.Click: Exit For '按下查詢
End If
Next
Do While .Busy Or .readyState <> 4: Loop
On Error Resume Next
If InStr(.Document.getElementsByTagName("TABLE")(3).outerHTML, "查無") Then GoTo Nn
If .Document.getElementsByTagName("TABLE")(3).Rows.Length > 1 Then
Ep .Document.getElementsByTagName("TABLE")(3).outerHTML
Else
GoTo Nn
End If
' If InStr(Selection.Cells(3, 1), "查無") Then Selection.Delete Shift:=xlUp: GoTo Nn
End With
With Sheets(1)
aa = Selection.Range("a3")
' If aa = "" Then aa = Selection.Range("a1") '會出錯才加入這段
If aa + 1911 <> X Then GoTo MR
End With
Next X
Nn:
If Sheets(1).Range("a1") = "" Then GoTo KK
xFile = xPath & "\" & E & "\HPM.txt"
MkDir_Sub xFile
Maketxt xFile, Sheets(1).Range("A1").CurrentRegion, E.Value
ii = ii + 1
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 匯入上市月成交 " & E & "共" & ii & " 文字檔"
KK:
Next E
IE.Quit
Application.StatusBar = Application.Text(Time - T, ["MM分SS秒"]) & " 共匯入上市月成交 " & ii & " 文字檔, 讀取完畢 !! "
MsgBox "匯入文字檔" & ii & " 費時 " & Application.Text(Time - T, ["MM分SS秒"])
' ThisWorkbook.Save
End Sub
Sub Ep(S As String)
Dim D As New DataObject, i As Integer, FormDLL As String, Rng As Range
'DataObject 物件在進行轉換動作時，做為格式化文字資料的暫存區域。其也可以暫存和儲存在 DataObject 的文字片段相關的格式。
'宣告 Dim D As New DataObject '須在工具-> 設定引用項目加入新增引用 Microsoft Forms 2.0 Object Library ,專案加入一表單即可
On Error GoTo ER
With D
.SetText S
.PutInClipboard
With Sheets(1)
With .Range("a" & .Rows.Count).End(xlUp)
If .Row = 1 Then
Set Rng = .Cells
Else
Set Rng = .Offset(1)
End If
Rng.Select
.Parent.PasteSpecial Format:="Unicode 文字"
Set Rng = Rng.Range("A3", Rng.Range("A3").End(xlDown)).Resize(, 9)
With Sheets(1).Sort
.SetRange Rng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sort :資料排序
' Rng.Sort Key1:=Rng.Range("B2"), Order1:=xlDescending, Header:=xlYes ', _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke, DataOption1:=xlSortNorma
' If .Row = 1 Then
' .Range("A2").EntireRow.Delete
' Else
' .Range("A2:A4").EntireRow.Delete
' End If
End With
End With
End With
Exit Sub
ER:
ThisWorkbook.VBProject.References.AddFromFile "C:\windows\system32\FM20.DLL"
Resume
End Sub
Sub Maketxt(xF As String, Q As Range, Code As String) '將匯入資料存入指定的txt
Dim fs As Object, E As Range, C As Variant, A As String, B As Integer, D As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.CreateTextFile(xF, True) '創見一個檔案,如檔案存在可覆蓋掉
A = Q.Cells(1)
B = Len(A)
If B >= 25 Then
D = Mid(A, 11, 4)
Else
D = Mid(A, 11, 2)
End If
Q.Cells(1) = Code & "-" & D & "" & " 月成交資料" '加入股票代號
If Q.Cells(3, 1).Offset(1) = "" Then GoTo EE
Q.Range("a3", Q.Range("a3").End(xlDown)).Replace "年度", ""
Q.Columns(1).SpecialCells(xlCellTypeBlanks).Offset(-1).EntireRow.Delete
Q.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
EE:
For Each E In Q.Rows
C = Application.Transpose(Application.Transpose(E.Value))
C = Join(C, vbTab)
fs.Write C
Next
fs.Close
End Sub
Sub MkDir_Sub(S As String)
Dim ar, i As Integer, xPath As String
If Dir(S) = "" Then
ar = Split(S, "\")
xPath = ar(0)
For i = 1 To UBound(ar) - 1
xPath = xPath & "\" & ar(i)
If Dir(xPath, vbDirectory) = "" Then MkDir xPath
Next
End If
End Sub

複製代碼

[attach]27345[/attach]

作者: GBKEE 時間: 2017-6-19 16:47

回復 86# smart3135

證交所網頁有流量管制.附檔有重新修改一些地方.

[attach]27356[/attach]

作者: smart3135 時間: 2017-6-20 18:41

回復 87# GBKEE
感謝版主阿，真的太實用了，我還有自己修改一些內容符合我想要的格式
另外上市年成交資訊是依您前一篇回覆的內容我也稍作修改，一樣可以正常抓資料了
真是受教了:handshake

作者: smart3135 時間: 2018-2-12 12:55

回復 87# GBKEE
版主您好，又來請教您了，半年前證交所改版後有請您幫忙，後來確實可以抓資料了
但今年測試，下載沒幾個就會卡住，我再去開證交所網頁就會開不起來
有請朋友幫忙測試，他們的電腦是可以開的，這是不是表示因為我在抓大量資料
所以會有流量或頻寬的限制？連結中的文章似乎也是說明如此
不知道程式碼還有沒有能修正的地方讓它可以正常抓資料，謝謝
https://www.wearn.com/bbs/t911387.html
[attach]28361[/attach]
[attach]28362[/attach]

作者: smart3135 時間: 2018-2-12 19:37

回復 89# smart3135
感謝版主回覆，找了一下，找不到相關的網頁，目前可以使用的方式就是用一樣的程式每次資料只能抓25筆左右
當無法抓的時候就將數據機關掉重開，等網路連線就可以再抓25筆，900多筆資料要慢慢抓，哈

作者: joey0415 時間: 2018-2-12 22:14

回復 90# smart3135

速度只能每三秒抓一次就不會鎖ip

慢一點當然更好

目前我也是這樣試出來的

作者: smart3135 時間: 2018-2-12 22:42

本帖最後由 smart3135 於 2018-2-12 22:57 編輯

回復 91# joey0415
不好意思請問要怎麼設定三秒抓一次不是很懂這個語法
我目前是暫時把IE.Applictation放在迴圈中，等抓完一檔後再跳下一檔前再將IE.Quit
鎖IP的情形有大幅改善，偶有發生，但仍比原來最多只抓25檔好很多了
[attach]28369[/attach]

作者: smart3135 時間: 2018-2-12 22:53

回復 87# GBKEE
版主，再請教一下，我有重新寫了一個VBA，和原來抓的方式不一樣，是用HTML網址下去抓
可以直接帶入變數股票號碼直接抓，問題是抓下來的日期格式在寫入文字檔時，就會自己轉換成2018/X/X
有我試著在寫進文字檔前將儲存格格式變更成文字，但卻會顯示成另一個數字(圖片綠框處)
不知道該怎麼寫才能讓日期顯示在excel的結果和網頁一樣，並且設定成文字格式，寫進文字檔時才不會又轉換成日期格式
再請您指導一下，謝謝。
[attach]28368[/attach]
[attach]28367[/attach]

作者: smart3135 時間: 2018-2-13 06:47

回復 93# smart3135
測試了一下，用新網頁去抓資料還是有流量限制，一樣到約25檔就抓不了了
語法中也未加入IE.Application，沒辦法做 IE.Quit，所以看來這個VBA還是沒辦法破解流量限制

作者: joey0415 時間: 2018-2-13 13:53

回復 94# smart3135

不是不行而是你沒有認真想

這是只其中一種等待的方法

for i=XXX to XXX
Application.Wait Now + TimeValue("00:00:03")

next

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