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

參考資料：


於