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