最新消息

[公告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)失效導致頁面載入變慢,目前已做調整,請多見諒。

2012年8月20日 星期一

Excel VBA抓每月合併營收



合併營收工作表中加入一個名為"下載"按鈕,如上圖中粉紅色按鈕,加入以下的程式碼
Option Explicit

Private Sub 合併營收_Click()
    Dim xlYear As String
    Dim xlMonth As String
    Dim xlKind As String
    Dim xlweburl As String
    
    If CDate(Range("B2") & "-" & Range("B3")) < CDate("2005-01") Then
        MsgBox "每月合併營收從2005年01月才公佈,請輸入正確年月", vbExclamation, "WARNING"
        Exit Sub
    End If
 
    If CDate(Year(Date) & "-" & Month(Date)) <= CDate(Range("B2") & "-" & Range("B3")) Then
        MsgBox "目前尚未公佈" & Range("B2") & "年" & Range("B3") & "月合併營收,請確認後再重新輸入", vbExclamation, "WARNING"
        Exit Sub
    End If
    
    If vbNo = MsgBox("您所要查詢的是" & Range("B1") & "公司" & Range("B2") & "年" & Range("B3") & "月份的合併營收嗎?", vbYesNo + vbQuestion) Then
        Exit Sub
    End If

    If StrComp(Range("B1"), "上市") = 0 Then
        xlKind = "sii"
    ElseIf StrComp(Range("B1"), "上櫃") = 0 Then
        xlKind = "otc"
    End If
    
    xlYear = CStr(CInt(Range("B2")) - 1911)
    xlMonth = Format(Range("B3"), "00")
    
    xlweburl = "http://mops.twse.com.tw/mops/web/ajax_t21sb06?TYPEK=" & xlKind & "&year=" & xlYear & "&month=" & xlMonth & "&step=1&firstin=1&off=1"
    取得合併營收 xlweburl
End Sub


以下程式碼加入"其他函數" Module
Sub 取得合併營收(weburl As String)
    Application.ScreenUpdating = False
    If 確認工作表存在() <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
    End If
    
    Call 清除工作表資料("Temp", "A1")
    Call 抓每月合併營收(weburl)
    刪特定列
    Call 清除工作表資料("合併營收", "A6")
    複製營收到工作表
    刪除暫存工作表
    Application.ScreenUpdating = True
    
    Sheet1.Select
End Sub

Sub 刪特定列()
    Dim i As Integer, j As Integer, Record As Integer
    
    Record = Worksheets("Temp").Range("A65536").Rows.End(xlUp).Row
    j = 0
    For i = 1 To Record
        Rows(i & ":" & i).Select
        If ActiveCell.Value = Empty Then
            j = j + 1
            Selection.EntireRow.Delete Shift:=xlUp
            If Record - j >= i Then
                i = i - 1
            End If
        End If
    Next
End Sub

Sub 複製營收到工作表()
    Dim n As Integer
    
    Sheets("Temp").Select
    n = Range("A65536").Rows.End(xlUp).Row
    ActiveSheet.Range("A2:J" & n).Copy
    
    Sheet1.Select
    Range("A6").Select
    ActiveSheet.Paste
End Sub

Sub 刪除暫存工作表()
    Application.DisplayAlerts = False
    Worksheets("Temp").Select
    Worksheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub

以下程式碼加入"抓網頁資料" Module 
Sub 抓每月合併營收(weburl As String)
    Sheets("Temp").Activate

    With ActiveSheet.QueryTables.Add("URL;" & weburl, Destination:=Range("A1"))
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .Refresh 0
        .Delete
        If Err.Number <> 0 Then Err.Clear: MsgBox "資料查詢失敗"
    End With
End Sub

以下程式碼加入"公用函數" Module 
Function 清除工作表資料(sheetname As String, cellpos As String)
    Dim n As Integer
    Dim qyt As QueryTable
    
    Worksheets(sheetname).Select
    n = ActiveSheet.Range("A65536").Rows.End(xlUp).Row
    For Each qyt In Worksheets(sheetname).QueryTables
        qyt.Delete
    Next
    ActiveSheet.Range(cellpos & ":J" & n).Clear
    ActiveSheet.Range(cellpos & ":J" & n).ClearContents
End Function

Function 確認工作表存在() As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets("Temp")
    If Not ws Is Nothing Then
        SheetExists = True
        On Error GoTo 0
        Exit Function
    End If
    SheetExists = False
    On Error GoTo 0
End Function

如果覺得自己寫很麻煩,可至這裡下載