麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 此vba走完，整個excel好像lag了，不曉得可以怎樣修改 [打印本頁]

作者: cji3cj6xu6 時間: 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 時間: 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

作者: handsometrowa 時間: 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

作者: GBKEE 時間: 2013-7-4 14:07

回復 1# cji3cj6xu6
修改如下

Option Explicit
Sub GGetPrice()
Dim StartYear, StockNumber As Integer, URL As String, xlMonth As String, R As Integer, R1 As Integer
StartYear = 2013
StartYear = DateSerial(StartYear, 1, 0) '起始日=>去年最後一天
StockNumber = 1101 '股票代號
Sheets(1).Cells.Clear '清除欲存放的頁面
On Error Resume Next '外部查詢的網址有誤會有錯誤(日期超過)
Do While Err.Number = 0
StartYear = DateAdd("M", 1, StartYear) '起始日的下一個月日期
xlMonth = Format(StartYear, "YYYYMM") & "/" & Format(StartYear, "YYYYMM")
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")
With Sheets(2) '清除抓取資料存放的頁面
If .QueryTables.Count = 0 Then
With .QueryTables.Add(URL, .[A1])
.Refresh BackgroundQuery:=False
End With
End If
With .QueryTables(1)
.Connection = URL
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "8"
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = False
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
With .ResultRange
R = Application.CountA(Sheets(1).[A:A])
R1 = IIf(R = 0, 3, 4)
.Rows(R1).Resize(.Rows.Count - R1 + 1).Copy Sheets(1).Cells(R + 1, 1)
End With
End With
End With
Loop
Sheets(1).Columns.AutoFit
MsgBox "OK!"
End Sub

複製代碼

作者: cji3cj6xu6 時間: 2013-7-4 14:33

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

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

作者: GBKEE 時間: 2013-7-4 15:59

回復 5# cji3cj6xu6
比對上市,上櫃的網址,依樣畫葫蘆,試試看.

作者: cji3cj6xu6 時間: 2013-7-4 16:48

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)