最新消息

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

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

[公告2018/04/22] 台北 Python + Excel VBA 金融資訊爬蟲課程,課程如網頁內容 金融資訊爬蟲班:台北班 Python 金融資訊爬蟲、EXCEL VBA 金融資訊爬蟲

[公告2019/01/08] 請注意:我再次重申,部落格文章的程式碼,是要提供各位參考與學習,一旦網頁改版請自行修改,別要求東要求西要我主動修改,你們用我寫東西賺錢了、交差了,請問有分我一杯羹嗎?既然賺錢沒分我,請問有什麼理由要求我修改,如果沒能力改,就花錢來找我上課。

[公告2019/12/01] 若各位有 Excel VBA 案子開發需求,歡迎與我聯繫,可接案處理。

[公告2020/05/22] 頁面載入速度慢,起因為部分JS來源(alexgorbatchev.com)失效導致頁面載入變慢,目前已做調整,請多見諒。

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

參考資料: