Board logo

標題: [發問] 依次記錄各股殖利率 [打印本頁]
作者: bhsm    時間: 2014-8-9 10:39     標題: 依次記錄各股殖利率

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

本帖最後由 GBKEE 於 2014-8-9 14:10 編輯

回復 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    時間: 2014-8-9 14:56

回復 2# GBKEE

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

本帖最後由 GBKEE 於 2014-8-10 05:55 編輯

回復 3# bhsm

[attach]18876[/attach]
   
只留ㄧ張[常用代碼] 工作表就可以
  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    時間: 2014-8-10 15:09

回復 4# GBKEE

感謝GBKEE大，小弟安裝上出現一些問題想再請教您，詳情請看TEST.rar內的說明，謝謝。
作者: GBKEE    時間: 2014-8-10 16:46

回復 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    時間: 2014-8-10 18:22

回復 6# GBKEE

非常感謝GBKEE大的有問必答，目前殖利率1-1.xls已可正常運作，但殖利率1-2.xls仍然出現附檔的訊息[attach]18878[/attach]
作者: GBKEE    時間: 2014-8-11 05:26

回復 7# bhsm
這是你所說的錯誤內容
  1. 表單己經顯示；不能再以強制回應的方式顯示此表單 (錯誤 400)
  2. 您不能用 Show 方法，以強制回應的方式顯示一個可見的表單。這項錯誤的原因及解決方法如下：
  3. 您試圖在可見的表單上，使用將 style 引數設定成 1 - vbModal 的 Show。
  4. 請在以強制回應的方式顯示表單之前，使用 Unload 陳述式或 Hide 方法。
複製代碼
請問你執行Sheet3.主程式時還執行有其他的程式嗎?
這是你的殖利率1-2.xls,沒有錯誤 400的發生

[attach]18879[/attach]
作者: bhsm    時間: 2014-8-11 12:26

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

回復 9# bhsm
會是你IE的關係嗎?(試試 IE重安裝)
作者: bhsm    時間: 2014-8-11 15:21

回復 10# GBKEE
感謝GBKEE大指導.電腦原使用IE11.移除後.重新安裝IE8.結果正常了.沒出現400的訊息.真是謝謝您了
作者: bhsm    時間: 2015-4-23 13:25

GBKEE大您好:
之前小弟曾承蒙您指教VBA程式， 但現在因小弟希望增加資料，同樣在”常用代碼"的工作表中雙擊股票編號，但不只能帶入”估價"工作表中的殖利率，也希望能帶入”股本”、”股東權益報酬率”、”上市(櫃)時間”， 不知能否請GBKEE大再指導一次，謝謝。[attach]20781[/attach]
作者: GBKEE    時間: 2015-4-23 14:48

回復 12# bhsm
  1. Option Explicit
  2. Private Sub Worksheet_Calculate()   '估價 [工作表模組]的程式碼
  3.     If Not Sheet3.Rng Is Nothing Then
  4.         'Sheet3.Rng       'SheetS("常用代碼")雙擊的處存格
  5.       Sheet3.Rng.Resize(, 4) = Array([c5].Text, [F3].Text, [F4].Text, [C8].Text)
  6.        ' With Sheet3.Rng
  7.        '    .Cells = [c5].Text
  8.        '    .Cells(1, "B") = [F3].Text
  9.        '    .Cells(1, "C") = [F4].Text
  10.        '    .Cells(1, "D") = [C8].Text
  11.        ' End With
  12.     End If
  13. End Sub
複製代碼
作者: bhsm    時間: 2015-4-23 18:30

回復 13# GBKEE
感謝GBKEE大,謝謝您
作者: bhsm    時間: 2015-4-24 11:16

回復  bhsm
GBKEE 發表於 2015-4-23 14:48

GBKEE大您好:
我把您教的這個VBA套用在公司的檔案上時，用2003操作都沒問題，但把該檔轉成2010時，操作上卻會發生"執行階段錯誤"28"  堆疊空間不足，當我按下偵錯時，程式會指向
"Sheet28.Rng.Resize(, 4) = Array([L5].Text, [L6].Text, [C14].Text, [B13].Text)"，如果在昨天傳給您的150423.rar檔案轉成2010時，操作沒問題，但套用到公司另外檔案時卻會
發生堆疊空間不足，請問應該修改哪裡來排除問題，謝謝
作者: GBKEE    時間: 2015-4-24 16:21

回復 15# bhsm
堆疊空間不足，Stop 後按下 F8 看看程式如何執行
  1. Stop
  2.       Sheet3.Rng.Resize(, 4).Value = Array([c5].Text, [F3].Text, [F4].Text, [C8].Text)
  3.       
複製代碼
作者: bhsm    時間: 2015-4-24 17:16

本帖最後由 bhsm 於 2015-4-24 17:17 編輯

回復 16# GBKEE
向GBKEE大回報，
1.雙擊代碼後會出現圖1
[attach]20786[/attach]
2.按下F8後出現圖2，此時資料未帶入所需位置
[attach]20787[/attach]
3.接著再按一次F8，出現圖3，此時檢視資料都已帶入，但此時須關閉VBA視窗，並停止偵錯，EXCEL才可繼續使用
[attach]20788[/attach]
4.重複1.之動作
作者: stillfish00    時間: 2015-4-24 17:21

回復 15# bhsm
個人經驗供參考:
可以檢查你的另外檔案的工作表/活頁簿用到的Event
常見堆疊空間不足的原因"之一"
可能是Event中某些程式碼行為又觸發了其他Event，然後一直不斷循環觸發...

如果是這原因，可在Event事件中適當設定Application.EnableEvents
暫時避免觸發其他event，最後再還原。
作者: bhsm    時間: 2015-4-24 17:35

回復 18# stillfish00
感謝stillfish00大,小弟納悶的是為何EXCEL2003使用上沒問題,但轉成2010時,卻會造成堆疊空間不足,理論上若有程式一直不斷循環觸發,那在2003是不是也應該發生呢?還請您解惑,謝謝
作者: stillfish00    時間: 2015-4-24 17:35

回復 17# bhsm
可以改這樣測測看
  1. Private Sub Worksheet_Calculate()
  2.     Application.EnableEvents = False
  3.     On Error GoTo EXIT_THIS
  4.    
  5.     If
  6.    
  7.     ........
  8.    
  9.     End If

  11. EXIT_THIS:
  12.     If Err.Number > 0 Then
  13.         MsgBox Err.Description
  14.         Stop
  15.         Resume  'F8 goto error line
  16.     End If
  17.     Application.EnableEvents = True
  18. End Sub
複製代碼
作者: bhsm    時間: 2015-4-24 17:57

回復 20# stillfish00
感謝stillfish00大，照您的程式修改後已可以使用了，謹在此謝謝您及GBKEE大.
作者: stillfish00    時間: 2015-4-24 18:15

回復 19# bhsm
我沒2003無法測，當然理論上要一致
但2003到2010 , Excel背後Calculate的機制也改變很多了
有這種不同也不無可能。
畢竟哪些程式碼會觸發哪些event , 這部分在Excel說明中我也沒看到...

總之我是覺得Event中代碼前後，用Application.EnableEvents控制開關，
應該是不會錯的好習慣啦(雖然我也常忘記)
作者: bhsm    時間: 2015-4-24 23:39

回復 22# stillfish00
雖然因為才疏學淺不太了解stillfish00大的解釋，但仍非常感謝您，謝謝



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