有興趣的自行下載程式研究。
'[2014/08/16] 修正尋找日期格式的問題
Option Explicit
Const xlStartYear As Integer = 2014
Const xlStartMonth As Integer = 1
Const xlStartDay As Integer = 1
Const xlFilePath As String = "C:\期貨下載資料\"
Sub 大盤與融資()
Application.ScreenUpdating = False
If Dir(xlFilePath, vbDirectory) = "" Then
MkDir (xlFilePath)
End If
ClaerChartObjects
With Workbooks(1).Worksheets(1)
.UsedRange.ClearContents
.Cells(1, 1) = "交易日期"
.Cells(1, 2) = "自營商"
.Cells(1, 3) = "投信"
.Cells(1, 4) = "外資及陸資"
.Cells(1, 5) = "開盤價"
.Cells(1, 6) = "最高價"
.Cells(1, 7) = "最低價"
.Cells(1, 8) = "收盤價"
End With
期貨交易數
期貨指數
Worksheets(1).Cells.EntireColumn.AutoFit
Worksheets(1).Cells.HorizontalAlignment = xlCenter
繪圖
Application.ScreenUpdating = True
End Sub
Sub 期貨交易數()
Dim url As String
Dim i, j, k, xlCount, xlPos, xlRow, xlDays, xlDayNo As Integer
Dim xlDate, xlFilename As String
Dim xlTemp '<=[2014/08/16]
xlCount = 2
If Hour(Time) >= 0 And Hour(Time) < 14 Then
xlDayNo = Day(Date) - 1
Else
xlDayNo = Day(Date)
End If
url = "http://www.taifex.com.tw/chinese/3/7_12_8dl.asp?goday=&syear=" & xlStartYear & "&smonth=" & xlStartMonth & "&sday=" & xlStartDay & "&eyear=" & Year(Date) & "&emonth=" & Month(Date) & "&eday=" & xlDayNo & "&COMMODITY_ID=TXF"
xlFilename = xlFilePath + "交易數.CSV"
下載檔案 url, xlFilename
With Workbooks.Open(xlFilename)
xlRow = .ActiveSheet.Range("A65536").End(xlUp).Row
For i = xlStartYear To Year(Date)
For j = xlStartMonth To Month(Date)
xlDays = Day(DateSerial(Format(i, "0000"), Format(j, "00") + 1, 1) - 1)
For k = xlStartDay To xlDays
xlDate = Format(i, "0000") & "/" & Format(j, "0") & "/" & Format(k, "0")
Set xlTemp = .ActiveSheet.Range("A:A").Find(CDate(xlDate), , xlValues, xlWhole, xlByRows, xlNext, True) '<=[2014/08/16]
If Not xlTemp Is Nothing Then '<=[2014/08/16]
xlPos = Range(xlTemp.Address).Row '<=[2014/08/16]
ThisWorkbook.Worksheets(1).Range("A" & xlCount & ":A" & xlCount) = CDate(xlDate)
.ActiveSheet.Range("N" & xlPos & ":N" & (xlPos + 2)).Copy
ThisWorkbook.Worksheets(1).Range("B" & xlCount).PasteSpecial Paste:=xlPasteValues, Transpose:=True
xlCount = xlCount + 1
End If
Next k
Next j
Next i
.Close 0
End With
Set xlTemp = Nothing '<=[2014/08/16]
End Sub
Sub 期貨指數()
Dim i, j, k, xlDays, xlCount, xlRow, xlPos As Integer
Dim xlDate, url As String
Dim xlFilename As String
Dim xlTemp '<=[2014/08/16]
xlCount = 2
For i = xlStartYear To Year(Date)
For j = xlStartMonth To Month(Date)
xlDays = Day(DateSerial(Format(i, "0000"), Format(j, "00") + 1, 1) - 1)
url = "http://www.taifex.com.tw/chinese/3/3_1_2dl.asp?datestart=" & Format(i, "0000") & "%2F" & Format(j, "00") & "%2F" & Format(1, "00") & "&dateend=" & Format(i, "0000") & "%2F" & Format(j, "00") & "%2F" & Format(xlDays, "00") & "&COMMODITY_ID=TX"
xlFilename = xlFilePath + "\期貨指數" + Format(i, "0000") + Format(j, "00") + ".CSV"
下載檔案 url, xlFilename
With Workbooks.Open(xlFilename)
xlRow = Range(.ActiveSheet.Range("A:A").Find("價差商品").Address).Row - 3
For k = 1 To xlDays
xlDate = Format(i, "0000") & "/" & Format(j, "0") & "/" & Format(k, "0")
Set xlTemp = .ActiveSheet.Range("A1:A" & xlRow).Find(CDate(xlDate), , xlValues, xlWhole, xlByRows, xlNext, True) '<=[2014/08/16]
If Not xlTemp Is Nothing Then '<=[2014/08/16]
xlPos = Range(xlTemp.Address).Row '<=[2014/08/16]
.ActiveSheet.Range("D" & xlPos & ":G" & xlPos).Copy _
Destination:=ThisWorkbook.Worksheets(1).Range("E" & xlCount & ":H" & xlCount)
xlCount = xlCount + 1
End If
Next k
.Close 0
End With
Set xlTemp = Nothing '<=[2014/08/16]
Next j
Next i
End Sub
Sub 下載檔案(url As String, xlFilename As String)
Dim oXMLHTTP, objStream As Object
Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
Set objStream = CreateObject("ADODB.stream")
With oXMLHTTP
.Open "POST", url, False
.send
If .readyState = 4 Then '.Status = 200
With objStream
.Type = 1
.Open
.Write oXMLHTTP.ResponseBody
If Dir(xlFilename) <> "" Then Kill xlFilename
.SaveToFile xlFilename
.Close
End With
End If
End With
Set oXMLHTTP = Nothing
Set objStream = Nothing
End Sub
Sub 繪圖()
Dim i, nRow As Integer
ClaerChartObjects
nRow = Worksheets(1).Range("A65536").End(xlUp).Row
With ActiveSheet.ChartObjects.Add(Left:=400, Top:=33, Width:=701, Height:=445).Chart
.HasTitle = True
.ChartTitle.Text = "期貨指數與未平倉餘額"
With .SeriesCollection.NewSeries
.ChartType = xlLineMarkers '圖表類型
.Values = Range("H2:H" & nRow) '數值
.XValues = Range("A2:A" & nRow) 'X軸
.Name = "期貨指數" '圖表名稱
.AxisGroup = xlPrimary
End With
With .SeriesCollection.NewSeries
.ChartType = xlLineMarkers '圖表類型
.Values = Range("D2:D" & nRow) '數值
.XValues = Range("A2:A" & nRow) 'X軸
.Name = "外資及陸資" '圖表名稱
.AxisGroup = xlSecondary
End With
With .SeriesCollection.NewSeries
.ChartType = xlLineMarkers '圖表類型
.Values = Range("C2:C" & nRow) '數值
.XValues = Range("A2:A" & nRow) 'X軸
.Name = "投信" '圖表名稱
.AxisGroup = xlSecondary
End With
With .SeriesCollection.NewSeries
.ChartType = xlLineMarkers '圖表類型
.Values = Range("B2:B" & nRow) '數值
.XValues = Range("A2:A" & nRow) 'X軸
.Name = "自營商" '圖表名稱
.AxisGroup = xlSecondary
End With
'.Legend.Delete
.Legend.Position = xlBottom 'xlLegendPositionBottom 或 xlBottom都可
With .Axes(xlCategory) 'X軸設定
.HasTitle = True
.AxisTitle.Text = Range("A1:A1")
.AxisTitle.Font.Size = 12
End With
With .Axes(xlValue, xlPrimary) '左邊 Y軸設定
.HasTitle = True
.AxisTitle.Text = "期貨指數" '左邊 Y軸名稱
.AxisTitle.Font.Size = 12
.AxisTitle.Orientation = xlVertical '字體方向旋轉
.AxisTitle.VerticalAlignment = xlCenter
.AxisTitle.HorizontalAlignment = xlCenter
End With
With .Axes(xlValue, xlSecondary) '右邊 Y軸設定
.HasTitle = True
.AxisTitle.Text = "多空淨額" '右邊 Y軸名稱
.AxisTitle.Font.Size = 12
.AxisTitle.Orientation = xlVertical '字體方向旋轉
.AxisTitle.VerticalAlignment = xlCenter
.AxisTitle.HorizontalAlignment = xlCenter
End With
End With
End Sub
Sub ClaerChartObjects()
Dim Chtobj As ChartObject
For Each Chtobj In ActiveSheet.ChartObjects
Chtobj.Delete
Next
End Sub
執行畫面
沒有留言:
張貼留言