Excel VBA抓每月營收

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

Option Explicit

Private Sub 營收_Click()
    Dim xlYear As String
    Dim xlMonth As String
    Dim xlKind As String
    Dim weburl As String
    
    If CDate(Range("B2") & "-" & Range("B3")) < CDate("2001-06") Then
        MsgBox "每月營收從2001年06月才公佈,請輸入正確年月", 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(Range("B2") - 1911)
        
    If (Range("B3") < 10) Then
        xlMonth = Format(Range("B3"), "0")
    Else
        xlMonth = Format(Range("B3"), "00")
    End If
    
    weburl = "http://mops.twse.com.tw/t21/" & xlKind & "/t21sc03_" & xlYear & "_" & xlMonth & ".html"
     
    取得營收 weburl
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 刪空白列
    Call 清除工作表資料("營收", "A6")
    
    複製營收到工作表
    刪除暫存工作表
    Application.ScreenUpdating = True
    
    Sheet1.Select
End Sub

Sub 刪空白列()
    Dim i As Integer, j As Integer, Record As Integer
    
    Worksheets("Temp").Select
    
    Record = Range("A65536").Rows.End(xlUp).Row
    j = 0
    For i = 1 To Record
        Rows(i & ":" & i).Select
        If ActiveCell.Value = Empty Or _
           ActiveCell.Value = "公司" Or _
           ActiveCell.Value = "代號" Or _
           ActiveCell.Value = "合計" Then
            
           j = j + 1
           Selection.EntireRow.Delete Shift:=xlUp
           'Selection.Delete Shift:=xlUp
           If Record - j >= i Then
            i = i - 1
           End If
        End If
    Next
End Sub

Sub 複製營收到工作表()
    Dim n As Integer
    
    Worksheets("Temp").Select
    n = Range("A65536").Rows.End(xlUp).Row
    ActiveSheet.Range("A1: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(Connection:= _
        "URL;" & weburl, Destination:=Range("A1"))
        .WebFormatting = xlWebFormattingNone
        .WebTables = _
        "3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61"
        .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 i As Integer
    CheckSheetExist = False
    For i = 1 To Worksheets.Count
        If "Temp" = Worksheets(i).Name Then
            CheckSheetExist = True
        End If
    Next
End Function

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