以下程式碼,請自行處理使用。
Option Explicit Const xlFilePath As String = "C:\期貨下載資料\" Sub 執行() Dim i As Integer Dim TXType(2) As String Application.ScreenUpdating = False TXType(0) = "TXF" TXType(1) = "MXF" For i = 0 To 1 取得未平倉量 TXType(i) 整理欄位與補0 TXType(i) 輸出CSV TXType(i) Next Application.ScreenUpdating = True End Sub Sub 取得未平倉量(sType As String) Dim url As String Dim i, xlCount, nsYear, nsMonth, nsDay, neYear, neMonth, neDay As Integer Dim strFilename As String Dim Tempsheet Dim Rng As Range Dim SheetName, ID SheetName = Array("外資未平倉量", "自營商未平倉量") ID = Array("外資及陸資", "自營商") If Dir(xlFilePath, vbDirectory) = "" Then MkDir (xlFilePath) End If For i = LBound(SheetName) To UBound(SheetName) With Workbooks(1).Sheets(sType + SheetName(i)) .UsedRange.ClearContents End With Next For i = 0 To 5 nsYear = Format(Year(Date) - 3, "0000") nsMonth = Format(Month(Date), "00") nsDay = Format(Day(Date), "00") neYear = Format(Year(Date), "0000") neMonth = Format(Month(Date), "00") neDay = Format(Day(Date) - i, "00") url = "http://www.taifex.com.tw/chinese/3/7_12_8dl.asp?goday=&syear=" & nsYear & "&smonth=" & nsMonth & "&sday=" & nsDay & "&eyear=" & neYear & "&emonth=" & neMonth & "&eday=" & neDay & "&COMMODITY_ID=" & sType strFilename = xlFilePath + "期貨.csv" 下載檔案 url, strFilename With Workbooks.Open(strFilename) If InStr(1, .ActiveSheet.Range("A1"), "DOCTYPE") = 0 Then .Close 0 Exit For End If .Close 0 End With Next With Workbooks.Open(strFilename) For i = LBound(SheetName) To UBound(SheetName) Set Rng = .ActiveSheet.UsedRange .ActiveSheet.AutoFilterMode = False With Rng .AutoFilter .AutoFilter Field:=3, Criteria1:=ID(i) End With Set Tempsheet = Workbooks(1).Worksheets(sType + SheetName(i)) xlCount = .ActiveSheet.Range("A65536").End(xlUp).Row .ActiveSheet.Range("A2:A" & xlCount).Copy Destination:=Tempsheet.Range("A1") .ActiveSheet.Range("N2:N" & xlCount).Copy Destination:=Tempsheet.Range("E1") Set Tempsheet = Nothing Set Rng = Nothing Next .Close 0 End With End Sub Sub 整理欄位與補0(sType As String) Dim i, j As Integer Dim nCount As Integer Dim SheetName SheetName = Array("外資未平倉量", "自營商未平倉量") For i = LBound(SheetName) To UBound(SheetName) With Sheets(sType + SheetName(i)) nCount = .Range("A65536").End(xlUp).Row For j = 1 To nCount If .Cells(j, 5) > 0 Then .Cells(j, 5).NumberFormatLocal = "##0_ " .Cells(j, 4) = .Cells(j, 5) Else .Cells(j, 5).NumberFormatLocal = "##0_ " .Cells(j, 3) = .Cells(j, 5) End If Next For j = 1 To nCount If .Cells(j, 2) = Empty Then .Cells(j, 2) = 0 End If If .Cells(j, 3) = Empty Then .Cells(j, 3) = 0 End If If .Cells(j, 4) = Empty Then .Cells(j, 4) = 0 End If Next End With Next End Sub Sub 輸出CSV(sType As String) Dim i As Integer Dim SheetName SheetName = Array("外資未平倉量", "自營商未平倉量") For i = LBound(SheetName) To UBound(SheetName) Workbooks.Add Workbooks(1).Sheets(sType + SheetName(i)).Cells.Copy Destination:=Workbooks(2).Sheets(1).Range("A1") Application.DisplayAlerts = False Workbooks(2).Sheets(1).SaveAs ThisWorkbook.Path & "\" & sType & SheetName(i) & ".csv", FileFormat:=xlCSV, CreateBackup:=False Application.DisplayAlerts = True Workbooks(2).Close 0 Next 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
參考資料: