返回列表 上一主題 發帖

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

cji3cj6xu6

帖子
112 
主題
19 
精華
0 
積分
136 
點名
0  
作業系統
window 
軟體版本
excel 
閱讀權限
20 
性別
男 
註冊時間
2013-3-12 
最後登錄
2022-11-29 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-7-4 10:15 | 只看該作者

[發問] 此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
收藏 分享

cji3cj6xu6

帖子
112 
主題
19 
精華
0 
積分
136 
點名
0  
作業系統
window 
軟體版本
excel 
閱讀權限
20 
性別
男 
註冊時間
2013-3-12 
最後登錄
2022-11-29 

論壇贊助勳章
2#
發表於 2013-7-4 10:17 | 只看該作者
而為了清除不必要的資料，寫了以下，但砍的很慢，不曉得要如何修正，謝謝！

    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

帖子
82 
主題
7 
精華
0 
積分
112 
點名
0  
作業系統
WIN7 
軟體版本
WIN7 
閱讀權限
20 
性別
男 
註冊時間
2013-1-3 
最後登錄
2020-9-21 
3#
發表於 2013-7-4 13:21 | 只看該作者
你可能要把範例檔案放上來大家比較好觀察你要的程序指令
一開始你第一次貼的那個應該是用巨集錄製的 才會有這麼多不需要的指令

If Range("a" & i).Value <> "(元,股)" Then
    Else
    Rows(i).Delete Shift:=xlUp
    End If

這段我有點不懂耶  你的Then 並不執行判斷後動作?
你這段的意思不是就等於

If Range("a" & i).Value <> "(元,股)" Then
      '要做什麼?
    Else '(不然要做以下動作)
    Rows(i).Delete Shift:=xlUp
    End If

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2013-7-4 14:07 | 只看該作者
回復 1# cji3cj6xu6
修改如下
  1. Option Explicit
  2. Sub GGetPrice()
  3.     Dim StartYear, StockNumber As Integer, URL As String, xlMonth As String, R As Integer, R1 As Integer
  4.     StartYear = 2013
  5.     StartYear = DateSerial(StartYear, 1, 0)     '起始日=>去年最後一天
  6.     StockNumber = 1101                          '股票代號
  7.     Sheets(1).Cells.Clear                       '清除欲存放的頁面
  8.     On Error Resume Next                      '外部查詢的網址有誤會有錯誤(日期超過)
  9.     Do While Err.Number = 0
  10.         StartYear = DateAdd("M", 1, StartYear)     '起始日的下一個月日期
  11.             xlMonth = Format(StartYear, "YYYYMM") & "/" & Format(StartYear, "YYYYMM")
  12.             URL = "URL;http://www.twse.com.tw/ch/trading/exchange/STOCK_DAY/genpage/Report" & xlMonth & "_F3_1_8_" & StockNumber & ".php?STK_NO=" & StockNumber & "&myear=" & Format(StartYear, "YYYY") & "&mmon=" & Format(StartYear, "MM")
  13.             With Sheets(2)                     '清除抓取資料存放的頁面
  14.                 If .QueryTables.Count = 0 Then
  15.                     With .QueryTables.Add(URL, .[A1])
  16.                         .Refresh BackgroundQuery:=False
  17.                     End With
  18.                 End If
  19.                 With .QueryTables(1)
  20.                     .Connection = URL
  21.                     .WebSelectionType = xlSpecifiedTables
  22.                     .WebFormatting = xlWebFormattingNone
  23.                     .WebTables = "8"
  24.                     .WebPreFormattedTextToColumns = False
  25.                     .WebConsecutiveDelimitersAsOne = False
  26.                     .WebSingleBlockTextImport = False
  27.                     .WebDisableDateRecognition = True
  28.                     .WebDisableRedirections = True
  29.                     .Refresh BackgroundQuery:=False
  30.                      With .ResultRange
  31.                         R = Application.CountA(Sheets(1).[A:A])
  32.                         R1 = IIf(R = 0, 3, 4)
  33.                         .Rows(R1).Resize(.Rows.Count - R1 + 1).Copy Sheets(1).Cells(R + 1, 1)
  34.                      End With
  35.             End With
  36.          End With
  37.        Loop
  38.        Sheets(1).Columns.AutoFit
  39.        MsgBox "OK!"
  40. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

cji3cj6xu6

帖子
112 
主題
19 
精華
0 
積分
136 
點名
0  
作業系統
window 
軟體版本
excel 
閱讀權限
20 
性別
男 
註冊時間
2013-3-12 
最後登錄
2022-11-29 

論壇贊助勳章
5#
發表於 2013-7-4 14:33 | 只看該作者
謝謝handsometrowa大的關心，正要po 上來，
沒料到善解人意的GBKEE大已將小弟的問題一併全解了，
多謝兩位～

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2013-7-4 15:59 | 只看該作者
回復 5# cji3cj6xu6
比對上市,上櫃的網址,依樣畫葫蘆,試試看.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

cji3cj6xu6

帖子
112 
主題
19 
精華
0 
積分
136 
點名
0  
作業系統
window 
軟體版本
excel 
閱讀權限
20 
性別
男 
註冊時間
2013-3-12 
最後登錄
2022-11-29 

論壇贊助勳章
7#
發表於 2013-7-4 16:48 | 只看該作者
http://www.otc.org.tw/ch/stock/aftertrading/daily_trading_info/st43.php
但上櫃的網址有異，要輸入年月日 ＆ 代號，然後按下查詢。
我再來想想看

TOP

        靜思自在 : 盡多少本份，就得多少本事。
返回列表 上一主題