- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
8#
發表於 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
|
|
發表於 2014-4-22 00:54
| 
