返回列表 上一主題 發帖

[發問] 此vba走完,整個excel好像lag了,不曉得可以怎樣修改

[發問] 此vba走完,整個excel好像lag了,不曉得可以怎樣修改

Sub GGetPrice()
    Dim DataQ As Integer, DQQ As Integer, DQ As Integer
    Dim StartYear, LastYear, CycleNumber, StockNumber As Integer
   
    StartYear = 2010
    LastYear = 2013
    CycleNumber = 1
    StockNumber = 1101
   
    Sheets("sheet7").Select  '清除欲存放的頁面
    Cells.Clear
   
    For DP = StartYear To LastYear
   
    Sheets("sheet7").Range("a1").Value = DP
   
   
        For DQ = 9 To 12
            
        Sheets("sheet6").Select        
        Cells.Clear                                '清除抓取資料存放的頁面

       [b1] = DQ
       [a1] = Sheets("sheet7").Range("a1").Value
      
       If DQ <= 9 Then
        With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.twse.com.tw/ch/trading/exchange/STOCK_DAY/genpage/Report" & [a1] & "0" & [b1] & "/" & [a1] & "0" & [b1] & "_F3_1_8_" & StockNumber & ".php?STK_NO=" & StockNumber & "&myear=" & [a1] & "&mmon=0" & [b1] & "", Destination:=Selection) '新增查詢
      
        Range("a2").Select
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables         
        .WebFormatting = xlWebFormattingNone
        .WebTables = "8"                                
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        '.Refresh BackgroundQuery:=False
        '.Name = .ResultRange.Cells(1, 1)
        
        '' 遇到錯誤繼續執行
              On Error Resume Next
              '' 網頁錯誤會在這行丟出錯誤碼在 Err.Numer 中
              .Refresh BackgroundQuery:=False
              If Err.Number Then
                '' 清除錯誤訊息, 並且回復預設的錯誤處理程序, 繼續跑下一天的資料
                Err.Clear
                On Error GoTo 0
         
              End If
              '' 回復預設的錯誤處理程序
              On Error GoTo 0

        Worksheets("sheet6").Select
        Range("A4:i30").Select
        Selection.Copy
   
        Data = 3 + (CycleNumber - 1) * 30
        Sheets("sheet7").Select
        Range("a" & Data).Select               
        ActiveSheet.Paste
                  
        CycleNumber = CycleNumber + 1
        
        End With
   
    Else
      
       With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.twse.com.tw/ch/trading/exchange/STOCK_DAY/genpage/Report" & [a1] & "" & [b1] & "/" & [a1] & "" & [b1] & "_F3_1_8_" & StockNumber & ".php?STK_NO=" & StockNumber & "&myear=" & [a1] & "&mmon=" & [b1] & "", Destination:=Selection)  '新增查詢
      
         
         Range("a2").Select
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables           
        .WebFormatting = xlWebFormattingNone
        .WebTables = "8"                              
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        '.Refresh BackgroundQuery:=False
        '.Name = .ResultRange.Cells(1, 1)
        
        '' 遇到錯誤繼續執行
              On Error Resume Next
              '' 網頁錯誤會在這行丟出錯誤碼在 Err.Numer 中
              .Refresh BackgroundQuery:=False
              If Err.Number Then
                '' 清除錯誤訊息, 並且回復預設的錯誤處理程序, 繼續跑下一天的資料
                Err.Clear
                On Error GoTo 0
         
              End If
              '' 回復預設的錯誤處理程序
              On Error GoTo 0
                           
        Worksheets("sheet6").Select
        Range("A7:i37").Select
        Selection.Copy
   
        Data = 3 + (CycleNumber - 1) * 30
        Sheets("sheet7").Select
        Range("a" & Data).Select               
        ActiveSheet.Paste
               
        CycleNumber = CycleNumber + 1
      
                 
    End With
    End If
   
   
    Next DQ
    Next DP
    End Sub

而為了清除不必要的資料,寫了以下,但砍的很慢,不曉得要如何修正,謝謝!

    Sub DeleteLine()
   
    Dim keyword As String
    Dim EndLine As Integer
   
    Sheets("sheet7").Select
   
    keyword = "endword"
    EndLine = 357
   
    Range("a" & EndLine + 1).Value = keyword
    cat = 0
   
    For i = 1 To EndLine
   
     keyword = "台泥"                                       '判斷有無輸入文字
   
    If Range("A" & i).Value Like "*" & keyword & "*" Then
    Rows(i).Delete Shift:=xlUp
    Else
    End If
   
   
    If Range("a" & i).Value <> "(元,股)" Then
    Else
    Rows(i).Delete Shift:=xlUp
    End If
   
    If Range("a" & i).Value <> "日期" Then
     Else
    Rows(i).Delete Shift:=xlUp
    End If
   
    For Q = 1 To 9
    If Range("a" & i).Value <> "" Then
     Else
    Rows(i).Delete Shift:=xlUp
    End If
    Next Q
   
    If Range("a" & i).Value <> "endword" Then
   
    Else
    i = EndLine
    End If
      
    'If cat = 1 Then
    'i = i - 1
    'Else
    'End If
   
    Next i
   
    Range("a1").Select
   
End Sub

TOP

謝謝handsometrowa大的關心,正要po 上來,
沒料到善解人意的GBKEE大已將小弟的問題一併全解了,
多謝兩位∼

但GBKEE大,請問一下,上櫃的資料要怎樣寫進來。謝謝!

TOP

http://www.otc.org.tw/ch/stock/aftertrading/daily_trading_info/st43.php
但上櫃的網址有異,要輸入年月日 & 代號,然後按下查詢。
我再來想想看

TOP

        靜思自在 : 能善用時間的人,必能掌握自己努力的方向。
返回列表 上一主題