- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
4#
發表於 2014-8-9 18:03
| 只看該作者
本帖最後由 GBKEE 於 2014-8-10 05:55 編輯
回復 3# bhsm
只留ㄧ張[常用代碼] 工作表就可以- Dim Sh As Worksheet
- Sub 主程式()
- Dim Rng As Range, AR(1 To 2) As String, Web_Table(1 To 2), i As Integer, R As Range
- AR(1) = "URL;https://tw.stock.yahoo.com/q/q?s=xxxx"
- AR(2) = "URL;https://tw.stock.yahoo.com/d/s/company_xxxx.html"
- Web_Table(1) = "7"
- Web_Table(2) = "8"
- Set Sh = Sheets("常用代碼")
- Set Rng = Sh.[a2:a27]
- Rng.Interior.ColorIndex = xlNone
- Rng.Offset(, 1).Resize(, 4) = ""
-
- Web查詢刪除
- Web查詢製定
- On Error GoTo L2
-
- For Each R In Rng
- For i = 1 To 2
- With Sh.QueryTables("_" & i)
- .Connection = Replace(AR(i), "xxxx", Trim(R))
- .WebSelectionType = xlSpecifiedTables
- .WebFormatting = xlWebFormattingNone
- .WebTables = Web_Table(i)
- .WebPreFormattedTextToColumns = True
- .WebConsecutiveDelimitersAsOne = True
- .WebSingleBlockTextImport = False
- .WebDisableDateRecognition = True
- .WebDisableRedirections = False
- .Refresh BackgroundQuery:=False '股號錯誤時會有錯誤
- If i = 1 Then
- R.Cells(1, 2) = Mid(.ResultRange.Cells(3, 1), Len(Trim(R)) + 1)
- R.Cells(1, 3) = .ResultRange.Cells(3, 3)
- R.Cells(1, 3).NumberFormatLocal = "#0.00"
- Else
- R.Cells(1, 4) = .ResultRange(3, 4)
- End If
- End With
- Next
- R.Cells(1, 5) = Val(R.Cells(1, 4)) / R.Cells(1, 3)
- R.Cells(1, 5).NumberFormatLocal = "0.00%"
- L1:
- Next
-
- Web查詢刪除
- Exit Sub
- L2:
- Err.Clear
- R.Interior.Color = vbYellow
- GoTo L1
- End Sub
- Private Sub Web查詢製定()
- Dim i As Integer
- For i = 1 To 2
- With Sh.Range("AA" & IIf(i = 1, 1, 50))
- With Sh.QueryTables.Add("URL;about:Tabs", .Cells) '空的網址
- .Name = "_" & i
- .Refresh BackgroundQuery:=False
- End With
- End With
- Next
- End Sub
- Private Sub Web查詢刪除()
- Dim Q As QueryTable
- For Each Q In Sh.QueryTables
- Q.ResultRange.Clear
- Q.Delete
- Next
- End Sub
|
|
發表於 2014-8-9 10:39
| 
