[發問] 依次記錄各股殖利率

bhsm

請問版上高手：在小弟的附檔中，由”常用代碼”的工作表雙擊代碼即可於”估價”的工作表C5取得該股殖利率，若小弟想由”常用代碼”的工作表雙擊A2代碼於”估價”的工作表取得A2的殖利率紀錄於”常用代碼”工作表中的C2，接著雙擊A3代碼於”估價”的工作表取得A3的殖利率紀錄於”常用代碼”工作表中的C3，依次直到A27，請問這巨集或VBA該如何寫?謝謝。

GBKEE

回復 1# bhsm
試試看

[估價]工作表模組

1. Private Sub Worksheet_Calculate()
   
2.     Sheet3.Rng = [c5].Text 'SheetS("常用代碼")
   
3. End Sub

複製代碼

[常用代碼]工作表模組

1. Public Rng As Range
   
2. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
3.     If Target.Column = 1 And Target.Row >= 2 And Target <> "" Then
   
4.         Cancel = True
   
5.         Sheets("估價").[c1].Value = Target.Value
   
6.         Set Rng = Target.Cells(1, "C")
   
7.     End If
   
8. End Sub

複製代碼

bhsm

回復 2# GBKEE

感謝GBKEE大指導.依您的方式已可雙擊"常用代碼"的A2~A27,並於C2~C27取得資料.想進一步請教:如果要讓"常用代碼"的A2~A27自動執行,請問巨集要如何寫?小弟嘗試用錄製巨集的方式,由雙擊A2開始.取得C2資料.再雙擊A3.取得C3資料----直到雙擊A27.取得C27資料後停止錄製巨集.但執行巨集時.游標卻直接跑到A27.請問這巨集該如何寫?謝謝

GBKEE

回復 3# bhsm

下載 (130.07 KB)

2014-8-9 18:01

   
只留ㄧ張[常用代碼] 工作表就可以

1. Dim Sh As Worksheet
   
2. Sub 主程式()
   
3.     Dim Rng As Range, AR(1 To 2) As String, Web_Table(1 To 2), i As Integer, R As Range
   
4.     AR(1) = "URL;https://tw.stock.yahoo.com/q/q?s=xxxx"
   
5.     AR(2) = "URL;https://tw.stock.yahoo.com/d/s/company_xxxx.html"
   
6.     Web_Table(1) = "7"
   
7.     Web_Table(2) = "8"
   
8.     Set Sh = Sheets("常用代碼")
   
9.     Set Rng = Sh.[a2:a27]
   
10.     Rng.Interior.ColorIndex = xlNone
    
11.     Rng.Offset(, 1).Resize(, 4) = ""
    
12.    
    
13.     Web查詢刪除
    
14.     Web查詢製定
    
15.     On Error GoTo L2
    
16.    
    
17.     For Each R In Rng
    
18.         For i = 1 To 2
    
19.             With Sh.QueryTables("_" & i)
    
20.                 .Connection = Replace(AR(i), "xxxx", Trim(R))
    
21.                 .WebSelectionType = xlSpecifiedTables
    
22.                 .WebFormatting = xlWebFormattingNone
    
23.                 .WebTables = Web_Table(i)
    
24.                 .WebPreFormattedTextToColumns = True
    
25.                 .WebConsecutiveDelimitersAsOne = True
    
26.                 .WebSingleBlockTextImport = False
    
27.                 .WebDisableDateRecognition = True
    
28.                 .WebDisableRedirections = False
    
29.                 .Refresh BackgroundQuery:=False '股號錯誤時會有錯誤
    
30.                If i = 1 Then
    
31.                     R.Cells(1, 2) = Mid(.ResultRange.Cells(3, 1), Len(Trim(R)) + 1)
    
32.                     R.Cells(1, 3) = .ResultRange.Cells(3, 3)
    
33.                     R.Cells(1, 3).NumberFormatLocal = "#0.00"
    
34.                Else
    
35.                     R.Cells(1, 4) = .ResultRange(3, 4)
    
36.                End If
    
37.             End With
    
38.         Next
    
39.             R.Cells(1, 5) = Val(R.Cells(1, 4)) / R.Cells(1, 3)
    
40.             R.Cells(1, 5).NumberFormatLocal = "0.00%"
    
41. L1:
    
42.     Next
    
43.    
    
44.     Web查詢刪除
    
45.     Exit Sub
    
46. L2:
    
47.     Err.Clear
    
48.     R.Interior.Color = vbYellow
    
49.     GoTo L1
    
50. End Sub
    
51. Private Sub Web查詢製定()
    
52.     Dim i As Integer
    
53.     For i = 1 To 2
    
54.         With Sh.Range("AA" & IIf(i = 1, 1, 50))
    
55.                 With Sh.QueryTables.Add("URL;about:Tabs", .Cells) '空的網址
    
56.                     .Name = "_" & i
    
57.                     .Refresh BackgroundQuery:=False
    
58.                 End With
    
59.             End With
    
60.         Next
    
61. End Sub
    
62. Private Sub Web查詢刪除()
    
63.     Dim Q As QueryTable
    
64.     For Each Q In Sh.QueryTables
    
65.         Q.ResultRange.Clear
    
66.         Q.Delete
    
67.     Next
    
68. End Sub

複製代碼

bhsm

回復 4# GBKEE

感謝GBKEE大，小弟安裝上出現一些問題想再請教您，詳情請看TEST.rar內的說明，謝謝。

GBKEE

回復 5# bhsm
1、啟檔案(出現錯誤訊息，原因如何，真的很想知道

因為當常用代碼工作表 尚未有雙擊A2的動作, 常用代碼模組的 Public Rng As Range 的 Rng變數還未指定Range
所以執行估價模組的Worksheet_Calculate程序時有錯誤, 沒有設定物件變數或 With 區塊變數 (錯誤 91)
可修改如下

1. Private Sub Worksheet_Calculate()
   
2.     Stop    'Worksheet_Calculate程序: 這工作表內公式的值有改變會執行一次
   
3.     If Not Sheet3.Rng Is Nothing Then
   
4.         Sheet3.Rng = [c5].Text 'SheetS("常用代碼")
   
5.     End If
   
6. End Sub

複製代碼

殖利率1-2.xls 2003環境執行很正常啊

bhsm

回復 6# GBKEE

非常感謝GBKEE大的有問必答，目前殖利率1-1.xls已可正常運作，但殖利率1-2.xls仍然出現附檔的訊息

下載 (174.99 KB)

2014-8-10 18:21

GBKEE

回復 7# bhsm
這是你所說的錯誤內容

1. 表單己經顯示；不能再以強制回應的方式顯示此表單 (錯誤 400)
   
2. 您不能用 Show 方法，以強制回應的方式顯示一個可見的表單。這項錯誤的原因及解決方法如下：
   
3. 您試圖在可見的表單上，使用將 style 引數設定成 1 - vbModal 的 Show。
   
4. 請在以強制回應的方式顯示表單之前，使用 Unload 陳述式或 Hide 方法。

複製代碼

請問你執行Sheet3.主程式時還執行有其他的程式嗎?
這是你的殖利率1-2.xls,沒有錯誤 400的發生

Ex.rar (11.54 KB)

下載次數: 24

2014-8-11 05:25

bhsm

回復 8# GBKEE
感謝GBKEE大的回答.我重新開機不開任何檔案.也不執行任何程式.直接執行您所附的殖利率1-2.xls.依舊出現400的錯誤訊息.這應該不是您的程式問題.我想應該是我的電腦有問題.幸好有第一個方式可解決.非常謝謝您

GBKEE

回復 9# bhsm
會是你IE的關係嗎?(試試 IE重安裝)