- 帖子
- 96
- 主題
- 18
- 精華
- 0
- 積分
- 125
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-3-23
- 最後登錄
- 2022-8-2
|
本帖最後由 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
|
|
發表於 2014-4-22 00:54
| 
