- 帖子
- 96
- 主題
- 18
- 精華
- 0
- 積分
- 125
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-3-23
- 最後登錄
- 2022-8-2
|
34#
發表於 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
 兩個月營收VBA.zip (38.38 KB)
|
|
發表於 2014-4-27 15:13
| 
