'COPYRIGHT BY dropit.liu.
Private Sub CommandButton1_Click()

Application.DisplayAlerts = False '關閉警告

i = 4 '設定儲存格起始值

While Sheets("營收彙整").Range("A" & i) <> "" '檢查儲存格有無資料          
        Sheets("營收盈餘").Cells.Clear '清楚資料        
        Sheets("營收盈餘").Activate '啟用工作頁              
        Call 新版營收("http://xxxxxxxxxxxxxxxxxxxx_" & Sheets("營收彙整").Range("A" & i) & ".djhtm") '使用網路爬蟲的副程式 ，網址請參考卷商歐，筆者不方便提供。        
        Set Rng = ActiveSheet.UsedRange.Find(What:="無資料") '透過find方法判斷資料有無              
        If Rng Is Nothing Then        
            Set Rng = ActiveSheet.UsedRange.Find(What:="年/月") '透過find方法找字串位置            
            If Rng Is Nothing Then                                            
                    S = 0                        
                    Sheets("營收彙整").Range("B" & i) = "?" '查無資料以問號註記          
            Else            
                    S = Rng.Row + 1 'Rng.Row為行資料，+1取得最新資料位置                                           
                    Sheets("營收彙整").Range("B" & i) = Sheets("營收盈餘").Range("b" & S)                        
                        '6個月                        
                    Sheets("營收盈餘").Range("M1").Formula = "=IF(SUMPRODUCT(--(F" & S & ":F" & S + 5 & ">=0))=6,TRUE,FALSE)"    '6個月為正
                    Sheets("營收盈餘").Range("M1").Calculate
                    Sheets("營收彙整").Range("C" & i) = Sheets("營收盈餘").Range("M1")                        
                        '3個月                        
                    Sheets("營收盈餘").Range("M1").Formula = "=IF(SUMPRODUCT(--(F" & S & ":F" & S + 2 & ">=0))=3,TRUE,FALSE)"   '3個月為正
                    Sheets("營收盈餘").Range("M1").Calculate
                    Sheets("營收彙整").Range("D" & i) = Sheets("營收盈餘").Range("M1")                        
                        '1個月                        
                    Sheets("營收盈餘").Range("M1").Formula = "=IF(SUMPRODUCT(--(F" & S & ">=0))=1,TRUE,FALSE)"     '1個月為正
                    Sheets("營收盈餘").Range("M1").Calculate
                    Sheets("營收彙整").Range("E" & i) = Sheets("營收盈餘").Range("M1")                        
                        If Sheets("營收盈餘").Range("F" & S) <> "" Then '整理資料
                           Sheets("營收彙整").Range("F" & i) = Sheets("營收盈餘").Range("F" & S)
                           Sheets("營收彙整").Range("G" & i) = Sheets("營收盈餘").Range("H" & S) '抓累計年增率
                         Else
                            Sheets("營收彙整").Range("F" & i) = "空白"                       
                        End If                                           
                    End If                                
        Else        
            S = 0

            Sheets("營收彙整").Range("B" & i) = "?"                        
        End If        
        Sheets("營收彙整").Activate           
   i = i + 1   
Wend

 Sheets("營收彙整").Activate

End Sub

爬蟲副程式暫時拿掉。4.23重補上

Sub 新版營收(url)

   Dim web, webdata     
   Set web = CreateObject("Microsoft.XMLHTTP")    
    web.Open "get", url, False    
    web.send    
    webdata = Split(web.responseText, vbLf)

 B = Filter(webdata, "查無")
    bv = Filter(webdata, "t3n1")    
    If UBound(bv) > 0 Then    
        ReDim S_DATA(UBound(bv), 6) As Variant
     End If
        A = 0
    
    If UBound(B) < 0 Then    
        For i = 0 To UBound(webdata) Step 1

                   If InStr(webdata(i), "t3n1") > 0 Then 'And InStr(webdata(i), "t3r1") > 0                
                              item1 = LTrim(webdata(i))                              
                              If i = 128 Then                              
                                i = i                                
                              End If
                               item1 = Split(item1, "/")                              
                              S_DATA(A, 0) = (Right(item1(0), 3)) & "/" & Left(item1(1), 2)
                              For S = 2 To UBound(item1) Step 1
                                 n2 = Split(item1(S), "td><td class=")
                                 n3 = 1
                                     If UBound(n2) > 0 Then
                                        x = Len(n2(1))
                                       For V = 0 To x Step 1                                        
                                          A1 = Mid(n2(1), n3, 1)                                          
                                          n3 = n3 + 1                                          
                                          If A1 = ">" Then                                          
                                            S_DATA(A, S - 1) = Mid(n2(1), n3, x - n3)                                            
                                            Exit For                                          
                                          End If                                          
                                        Next V                                        
                                    End If                              
                              Next S                                    
                        A = A + 1           
                   End If         
        Next i        
        Sheets("營收盈餘").Range("b8:h8") = Array("年/月", "合併營收", "月增率", "去年同期", "年增率", "累計營收", "年增率")        
        If IsArray(S_DATA) = True Then                
            If S_DATA(0, 1) <> "" Then            
                Sheets("營收盈餘").Range("b9:h" & A) = S_DATA                
            End If            
        End If        
    End If

End Sub