Excel VBA抓特定股票合併營收

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

Option Explicit

Private Sub 合併營收_Click()
    Dim xlStock As String
    Dim xlYearDiff As Integer
        
    xlStock = Range("B1")
    xlYearDiff = Range("D1")
    If Len(xlStock) < 4 Then
        MsgBox "輸入代號有誤,請重新輸入", vbExclamation, "WARNING"
        Exit Sub
    End If
    
    Call Run(xlStock, xlYearDiff)
End Sub

以下程式碼加入"一般函數" Module 

Sub Run(xlStock As String, xlYearDiff As Integer)

    Dim xlKind As String
    Dim xlYear, xlMonth, i As Integer
    Dim sheet1Headername, sheet2Headername
    
    Application.ScreenUpdating = False
    sheet1Headername = Array("年/月", "營收", "營收月增率(%)", "去年同月營收", "營收年增率(%)", "今年累積營收", "去年累計營收", "累積營收年增率(%)")
    sheet2Headername = Array("年/月", "公司代號", "公司名稱", "當月合併營收", "上月合併營收", "去年當月合併營收", "上月比較增減(%)", "去年同月增減(%)", "當年累計營收", "去年累計營收", "前期比較增減(%)")
   
    If CheckSheetExist() <> True Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
    End If

    清除最後資料
    For i = 0 To UBound(sheet1Headername)
        Sheet1.Cells(4, i + 1) = sheet1Headername(i)
    Next
    
    清除取出資料
    For i = 0 To UBound(sheet2Headername)
        Sheet2.Cells(1, i + 1) = sheet2Headername(i)
    Next
    
    
    If 找尋股票代碼(xlStock) = 0 Then
        xlKind = "sii"
    ElseIf 找尋股票代碼(xlStock) = 1 Then
        xlKind = "otc"
    Else
        MsgBox "您輸入錯誤股票代碼,請重新輸入", vbExclamation, "WARNING"
        Exit Sub
    End If
    
    
    i = 0
    For xlYear = Year(Date) - xlYearDiff To Year(Date)
        For xlMonth = 1 To 12
           If CDate(xlYear & "-" & xlMonth) < CDate(Year(Date) & "-" & Month(Date)) Then
                Sheet2.Range("A" & i + 2) = CStr(xlYear) & "/" & Format(xlMonth, "00")
                Call 清除暫存工作表

                If 抓每月營收(xlKind, CStr(xlYear - 1911), CStr(xlMonth)) <> True Then
                    MsgBox "股票" & xlStock & "沒有" & xlYear & "年" & xlMonth & "月的營收", vbExclamation, "WARNING"
                    Exit Sub
                End If
                
                Call 刪空白列
                Call 找尋股票複製到取出資料(xlStock, i)
                i = i + 1
            End If
        Next xlMonth
    Next xlYear

    Call DeleteTempSheet
    
    複製資料到最後資料工作表
    
    Application.ScreenUpdating = True
    Sheet1.Select
End Sub

Sub 複製資料到最後資料工作表()
    Dim temp
    Dim i As Integer, n As Integer
    
    temp = Array("A", "D", "G", "F", "H", "I", "J", "K")
    
    For i = 0 To UBound(temp)
        Sheet2.Select
        n = Range("A65536").Rows.End(xlUp).Row
        ActiveSheet.Range(temp(i) & "2" & ":" & temp(i) & n).Copy
        
        Sheet1.Select
        Range(Cells(5, i + 1).Address).Select
        ActiveSheet.Paste
    Next
    
    Sheet2.Select
    ActiveSheet.Range("C2").Copy
    
    Sheet1.Select
    Range("B2").Select
    ActiveSheet.Paste
End Sub

Sub 刪空白列()

    Dim i As Integer, j As Integer, Record As Integer
    
    Sheets("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
            If Record - j >= i Then
                i = i - 1
            End If
        End If
    Next
    Range("A:A").Select
End Sub

Sub 清除最後資料()
    Dim n As Integer
    Sheet1.Select
    If ActiveSheet.Range("A4") <> "" Then
        n = ActiveSheet.Range("A65536").Rows.End(xlUp).Row
        ActiveSheet.Range("A4:K" & n).Clear
        ActiveSheet.Range("A4:K" & n).ClearContents
    End If
End Sub

Sub 清除取出資料()
    Dim n As Integer
    Sheet2.Select
    If ActiveSheet.Range("A2") <> "" Then
        n = ActiveSheet.Range("A65536").Rows.End(xlUp).Row
        ActiveSheet.Range("A1:K" & n).Clear
        ActiveSheet.Range("A1:K" & n).ClearContents
    End If
End Sub

Sub DeleteTempSheet()
    Application.DisplayAlerts = False
    Worksheets("Temp").Select
    Worksheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub

以下程式碼加入"抓網頁資料" Module

Sub 股票代碼(StockIDUrl As String)

    Sheets("Temp").Activate

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

Function 抓每月營收(xlKind As String, xlYear As String, xlMonth As String) As Boolean
    Sheets("Temp").Activate
    
    On Error GoTo DownloadErr
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://mops.twse.com.tw/t21/" & xlKind & "/t21sc03_" & xlYear & "_" & xlMonth & ".html", _
        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
    
    抓每月營收 = True
    Exit Function
    
DownloadErr:
    抓每月營收 = False
    
End Function

以下程式碼加入"函數回傳" Module

Function 找尋股票代碼(stockid As String) As Integer
    Dim i As Integer, j As Integer
    Dim RowStart As Integer
    Dim RowEnd As Integer
    Dim tmp() As String
    Dim stockkind(2) As String
    
    stockkind(0) = "http://brk.twse.com.tw:8000/isin/C_public.jsp?strMode=2"
    stockkind(1) = "http://brk.twse.com.tw:8000/isin/C_public.jsp?strMode=4"
    
    For i = 0 To 1
    
        清除暫存工作表
        
        股票代碼 stockkind(i)
        
        With Sheets("Temp")
            RowStart = 3
            RowEnd = .Range("A65536").Rows.End(xlUp).Row
            
            For j = RowStart To RowEnd
                tmp = Split(.Cells(j, 1).Value, "  ")
                If stockid = tmp(0) Then
                    找尋股票代碼 = i
                    Exit Function
                End If
            Next j
        End With
    Next i
 
    找尋股票代碼 = 2
End Function

Function 找尋股票複製到取出資料(xlStock As String, i As Integer) As Boolean
    
    Dim Stockoffset As String, lastCol As Integer, lastRow As Integer
    
    On Error GoTo FindErr
    
    Sheets("temp").Select
    
    With Selection
        Stockoffset = .Range("A:A").Find(xlStock).Address
        lastCol = .Range(Stockoffset).End(xlToRight).Column
        lastRow = .Range(Stockoffset).Row
        .Range(Stockoffset & ":" & .Cells(lastRow, lastCol).Address).Select
        Selection.Copy
        Sheet2.Select
        Range("B" & i + 2).Select
        ActiveSheet.Paste
    End With
     
    找尋股票複製到取出資料 = True
    Exit Function
    
FindErr:
    找尋股票複製到取出資料 = False
End Function

Function CheckSheetExist() As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets("Temp")
    If Not ws Is Nothing Then
        CheckSheetExist = True
        On Error GoTo 0
        Exit Function
    End If
    CheckSheetExist = False
    On Error GoTo 0
End Function

Function 清除暫存工作表()
    Dim n As Integer
    Dim qyt As QueryTable
    
    Worksheets("Temp").Select
    n = ActiveSheet.Range("A65536").Rows.End(xlUp).Row
    For Each qyt In Worksheets("Temp").QueryTables
        qyt.Delete
    Next
    ActiveSheet.Range("A1:J" & n).Clear
    ActiveSheet.Range("A1:J" & n).ClearContents
End Function

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