iInfo 資訊交流: MultiCharts 匯入外部資料(2) --- Excel VBA 產生的外資、自營商 大台、小台 未平倉量檔案

最新消息

[公告2014/05/30] 如有需要將部落格中,任何一篇文章的程式碼使用在商業用途,請與我聯繫。

[公告2015/04/26] Line版的 iInfo程式與投資應用 群組已上線想加入的朋友們,請先查看 "入群須知" 再與我聯繫 Line : aminwhite5168,加入請告知身分與回答 "入群須知" 的問題。

[公告2017/02/20] 近來有網友詢問 MultiCharts 與 Excel 畫冰火能量圖 (8)MultiCharts 與Excel 畫冰火能量圖(11) --- 更名「台股儀表板」 文章中教學檔案取得方式,有興趣的朋友可透過 Line了解詳情 (請勿以為是免費分享),Line : aminwhite5168。

[公告2018/04/22] 台北 Python + Excel VBA 金融資訊爬蟲課程,於 7/21、7/22 兩天開課,課程如網頁內容 金融資訊爬蟲班:台北班 Python 金融資訊爬蟲、EXCEL VBA 金融資訊爬蟲,5/30 前早鳥優惠票,請盡快把握機會,歡迎券商、大專院校邀約講座。

[公告2018/06/01] 台指能量儀表板教學課程,課程如網頁內容 台北班:台指能量儀表板

2016年7月18日 星期一

MultiCharts 匯入外部資料(2) --- Excel VBA 產生的外資、自營商 大台、小台 未平倉量檔案

延續前面文章的作法,這節將擴充功能,一次產生4個檔案,大台外資未平倉量、大台自營商未平倉量、小台外資未平倉量、小台自營商未平倉量檔案,匯入MultiCharts的方法可以參考 MultiCharts 匯入外部資料(1) --- Excel VBA 產生的外資未平倉量檔案
以下程式碼,請自行處理使用。
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

參考資料: