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

Option Explicit
Sub Ex()
Dim i As Integer, rng As Range
With ActiveSheet
If .QueryTables.Count = 0 Then .QueryTables.Add "URL;", .[a1]
For i = 3 To 17 Step 2
'迴圈中ㄧ直的 querytable.add 檔案會胖起來,導致程式的速度越來越慢
With .QueryTables(1)
.Connection = "URL;http://forum.twbts.com/thread-635-1-1.html"
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = i & ""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
Wb_Save .ResultRange, i
End With
Next
End With
End Sub
Private Sub Wb_Save(Rng As Range, i As Integer) '副程式:新增活頁簿,存檔
With Workbooks.Add(1)
Rng.Copy .Sheets(1).[a1]
.Close True, "d:\test_" & i & ".xls"
'關閉存檔
End With
End Sub

複製代碼

Sub 取得資料(strURL As String, Table As String)
Dim xlSheet As Excel.Worksheet
Set xlSheet = Sheets("Temp")
Do
Application.DisplayAlerts = False
With xlSheet.QueryTables.Add("URL;" & strURL, xlSheet.Cells(1, 1))
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlSpecifiedTables
.WebTables = Table
.BackgroundQuery = False
On Error Resume Next
Do
Err.Clear
.Refresh 0
If Err.Number Then
Application.Wait Now + TimeValue("00:00:01")
End If
Loop Until Err.Number = 0
.Delete
'If Err.Number <> 0 Then Err.Clear: MsgBox Err.Number '被免資料抓取不成功,而顯示訊息
On Error GoTo 0
End With
If Err.Number = 0 Then
Application.DisplayAlerts = True
Exit Sub
End If
Loop
儲存CSV DownloadDate,id
End Sub
Sub 儲存CSV(SaveDate As String, CSVname As String)
Dim TestObj As Object
Dim CSVfile As String, CSVfolder As String
Dim TestFolder As Boolean
FilePath = "D:\TSE\"
CSVfolder = FilePath & SaveDate & "\"
CSVfile = CSVfolder & CSVname & "_" & SaveDate & ".csv"
'Debug.Print CSVfile
Set TestObj = CreateObject("Scripting.FileSystemObject")
TestFolder = TestObj.FolderExists(CSVfolder)
If TestFolder = False Then TestObj.CreateFolder (CSVfolder)
On Error Resume Next
Kill CSVfile
On Error GoTo 0
Worksheets(Tempname).Copy
Application.DisplayAlerts = False
With ActiveWorkbook
.SaveAs FileName:=CSVfile, FileFormat:=xlCSV
.Close 0
End With
Application.DisplayAlerts = True
End Sub

複製代碼

儲存CSV DownloadDate,id

複製代碼

t = timer
儲存CSV DownloadDate,id
debug.print timer-t

複製代碼

Sub Ex()
Dim i As Integer, Rng As Range
With ActiveSheet
For i = 3 To 7 Step 2
With .QueryTables.Add("URL;http://forum.twbts.com/thread-635-1-1.html", .Cells(1, 1))
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = i & ""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.RefreshStyle = xlOverwriteCells
.Refresh BackgroundQuery:=False
Wb_Save .ResultRange, i
.Delete
End With
Next
End With
End Sub

複製代碼

Option Explicit
Dim IE As Object, Query_Sh As Worksheet, CsvPath As String, SaveDate As String
Dim t As Date, StartTime As Date, 記錄檔 As String, stockid As Range, spListCount As Integer
Sub Main()
Dim i As Integer
t = Time
StartTime = Time
CsvPath = "D:\TSE\"
目錄 CsvPath
記錄檔 = CsvPath & "Main_Record.TXT"
If Dir(記錄檔) <> "" Then Kill 記錄檔
暫存頁 "temp"
xRecond 0, "程式開始執行" & vbCrLf
Set stockid = Sheets("工作表1").Range("A2")
stockid.Parent.Activate
Do While stockid <> ""
Application.ScreenUpdating = True
stockid.Select
Application.ScreenUpdating = False
StartTime = Time
spListCount = 資料頁數
If spListCount > 0 Then
i = i + 1
xRecond i, stockid & vbTab & "資料匯入"
資料匯入
整理
存檔
xRecond i, stockid.Value & vbTab & "存檔完畢 " & Format(Time - StartTime, "共SS秒") & vbCrLf
End If
Set stockid = stockid.Offset(1)
Loop
IE.Quit
Application.DisplayAlerts = False
Query_Sh.Delete
Application.DisplayAlerts = True
Workbooks.Open 記錄檔
MsgBox "共存 ""(" & i & ") csv檔完畢" & vbTab & "費時 " & Format(Time - t, "nn分ss秒")
End Sub
Private Sub 暫存頁(temp As String)
On Error Resume Next
Set Query_Sh = Sheets(temp)
If Err.Number = 9 Then
Sheets.Add(, Sheets(1)).Name = temp
Set Query_Sh = Sheets(temp)
End If
End Sub
Private Sub 資料匯入()
Dim strURL As String
strURL = "URL;" & "http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & stockid & "&FocusIndex=All_" & spListCount
With Query_Sh
.UsedRange.Clear
With .QueryTables.Add(strURL, Query_Sh.[a1])
.WebFormatting = xlWebFormattingNone
.WebSelectionType = xlSpecifiedTables
.WebTables = "5,table2"
.Refresh 0
.Delete
End With
End With
End Sub
Private Sub 整理()
Dim i As Integer
With Sheets("temp")
SaveDate = Format(.Range("B1"), "YYYYMMDD")
With .UsedRange.Range("A:A")
.SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
.UsedRange.Columns("F:J").Cut
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Insert Shift:=xlDown
.UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo
.UsedRange.Columns("B:B").Insert Shift:=xlToRight
.UsedRange.Columns(1) = SaveDate
.UsedRange.Columns(2) = stockid
For i = 1 To .UsedRange.Rows.Count
.Cells(i, 3) = Left(.Cells(i, 3), 4)
.Cells(i, 5) = .Cells(i, 5).Value / 1000
.Cells(i, 6) = .Cells(i, 6).Value / 1000
Next
End With
End Sub
Private Sub 目錄(xPath As String)
Dim SP As Variant, P As String, i As Integer
SP = Split(xPath, "\")
P = SP(0)
With CreateObject("Scripting.FileSystemObject")
For i = 1 To UBound(SP)
P = P & "\" & SP(i)
If .FolderExists(P) = False Then .CreateFolder (P)
Next
End With
End Sub
Private Sub 存檔()
Dim CSVfolder As String, CSVfile As String
CSVfolder = CsvPath & SaveDate & "\"
目錄 CSVfolder
CSVfile = CSVfolder & stockid & "_" & SaveDate & ".csv"
If Dir(CSVfile) <> "" Then Kill CSVfile
Query_Sh.Copy
With ActiveWorkbook
.SaveAs Filename:=CSVfile, FileFormat:=xlCSV
.Close 0
End With
End Sub
Private Sub xRecond(i As Integer, xSub As String)
Dim S As String
S = Time & vbTab & Format(Time - t, " 第nn分ss秒") & vbTab & " 第 " & i & " 個Csv檔 " & xSub
Close #1
Open 記錄檔 For Append As #1
Print #1, S
Close #1
Application.StatusBar = S
End Sub
Private Function 資料頁數() As Integer '取得頁數
If IE Is Nothing Then
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
IE.Visible = True '可不顯示
End If
With IE
Do: Loop While .Busy Or IE.ReadyState <> 4
With .document
.getElementByID("txtTASKNO").Value = stockid
.getElementByID("btnOK").Click
Do: Loop While IE.Busy Or IE.ReadyState <> 4 Or .getElementByID("sp_ListCount") Is Nothing
資料頁數 = Val(.getElementByID("sp_ListCount").innertext)
End With
End With
End Function

複製代碼

Cells.NumberFormatLocal = "G/通用格式"
可改成(縮小範圍)
UsedRange.NumberFormatLocal = "G/通用格式"

複製代碼