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

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