[發問] 有關使用事件程序取得資料(有二個問題)

icestormer

上圖是利用A2的物品名稱 去找到資料區內的賣價但現在是買價的公式寫不出來~~

下圖是各種物品資料 由於紅圈處資料筆數不同 所以不知應要怎寫公式讓EXCEL能取得　買價的價位（已附上檔案）
如果我有說明不清的地方，請見諒～～　




Book2.rar (13.75 KB)

下載次數: 11

2014-1-14 12:24

stillfish00

回復 1# icestormer
VBAProject
主工作表

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.   If Application.Intersect(Target, Range("F1:G1")) Is Nothing Then Exit Sub
   
3.   UpdatePrice
   
4. End Sub

複製代碼

一般模組

1. Sub UpdatePrice()
   
2.   Dim d, rng As Range
   
3.   Dim sName As String, sSell As String, sBuy As String
   
4.   Dim r As Long, c As Long, x
   
5.   
   
6.   Const sMark = " - Market Browser"
   
7.   Const sMarkSell = "Sell Orders (Buy Orders)"
   
8.   Const sMarkBuy = "Buy Orders"
   
9.   
   
10.   Set d = CreateObject("scripting.dictionary")
    
11.   
    
12.   With Sheets("資料區")
    
13.     For c = 1 To .UsedRange.Columns.Count Step 7  '6欄加上空白欄 = 7
    
14.       For r = 1 To .Cells(.Rows.Count, c).End(xlUp).Row Step 300 '固定300列
    
15.         sName = "": sSell = "": sBuy = ""
    
16.         With .Cells(r, c).Resize(300)
    
17.           Set rngName = .Find(sMark, LookIn:=xlValues, lookat:=xlPart)
    
18.           If rngName Is Nothing Then GoTo NEXT_BLOCK Else sName = Left(rngName.Value, Len(rngName.Value) - Len(sMark))
    
19.          
    
20.           Set rng = .Find(sMarkSell, LookIn:=xlValues, lookat:=xlWhole)
    
21.           If Not rng Is Nothing Then sSell = rng.Offset(3, 2).Value
    
22.          
    
23.           Set rng = .Find(sMarkBuy, LookIn:=xlValues, lookat:=xlWhole)
    
24.           If Not rng Is Nothing Then sBuy = rng.Offset(3, 2).Value
    
25.          
    
26.           d(sName) = Array(sSell, sBuy)
    
27.         End With
    
28. NEXT_BLOCK:
    
29.       Next
    
30.     Next
    
31.   End With
    
32.   
    
33.   '貼上價位
    
34.   With Sheets("主工作表")
    
35.     For Each x In .Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp))
    
36.       If d.exists(x.Value) Then x.Offset(, 1).Resize(, 2).Value = d(x.Value)
    
37.     Next
    
38.   End With
    
39. 
    
40. End Sub

複製代碼

icestormer

回復 2# stillfish00


  感恩 我去試試!

icestormer

回復 3# icestormer


    你好 程序會很順利的跑完但他不會更新呢,SORRY我沒有說明白 我是用下方指令這種來更新

  Selection.QueryTable.Refresh BackgroundQuery:=False

stillfish00

回復 4# icestormer
按上方[更新價位]字樣(F1 G1儲存格)

icestormer

回復 5# stillfish00


   

那個好像你誤會我的意思了

我再試者說明一次 主要是資料會有2 到3千筆 但是每次我也許只要更新其中1到3百筆(每種每次更新時種類不同)

我按下 更新價位時 他好像只會更新 主工作表上的B2到C4(目前上頭只有3筆資料)而不會去更新 資料區內的 如下圖

我想一個程式在我按下[更新市價]時 它會自動按[主工作表]上A2到AXXX(看有幾筆)
每一筆上的物品名稱(例如:Pyerite)去找到資料區內進而更新它 ,然後由於資料量大所以他可能會A那或是H或是更遠的AC300那裡
如果全部資料都在同一行(A1:A65536)那我還寫的出來但資料會分散開所以寫不出來><
再次感謝你的回覆!

stillfish00

回復 6# icestormer
所以你資料表是有很多很多外部資料連線組成，全部都更新太慢所以是要找到特定的外部資料更新連線就好，
然後再取回買賣價到主工作表，對嗎？

修改主工作表

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.   If Application.Intersect(Target, Range("F1:G1")) Is Nothing Then Exit Sub
   
3.   UpdateQueryTable
   
4.   UpdatePrice
   
5. End Sub

複製代碼

原本一般模組再加上:

1. Sub UpdateQueryTable()
   
2.   Dim ar, rng As Range, x
   
3.   Dim sMsg As String, bNotFound As Boolean
   
4.   
   
5.   Const sMark = " - Market Browser"
   
6.   sMsg = "以下找不到 : "
   
7.   
   
8.   With Sheets("主工作表")
   
9.     ar = Application.Transpose(.Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)).Value)
   
10.   End With
    
11.   
    
12.   With Sheets("資料區")
    
13.     For Each x In ar
    
14.       Set rng = .Cells.Find(x & sMark, LookIn:=xlValues, lookat:=xlWhole)
    
15.       If rng Is Nothing Then
    
16.         sMsg = sMsg & vbCrLf & x & sMark
    
17.         bNotFound = True
    
18.       Else
    
19.         rng.QueryTable.Refresh BackgroundQuery:=False
    
20.       End If
    
21.     Next
    
22.   End With
    
23.   
    
24.   If bNotFound Then MsgBox sMsg Else MsgBox "Finish"
    
25. End Sub

複製代碼

icestormer

回復 7# stillfish00


   對 沒錯 不然我只要看300筆但一次全部更新3千筆...這..太沒花時間也沒必要  感謝 我試試!^^

icestormer

回復 8# icestormer


   

你好 我一開始 試都OK(有3筆) 然後呢 我發現當只有一筆資料時(如上圖)就會發生錯誤  只要有2筆以上資料就不會出錯 不知要修改那裡呢?


另外 我把那一行去掉 updateprice   要跑時有錯誤

stillfish00

回復 9# icestormer
改上面
  With Sheets("主工作表")
    ar = Application.Transpose(.Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)).Value)
    If Not IsArray(ar) Then ar = Array(ar)
  End With


去掉 updateprice   要跑時有錯誤
不懂，不可能取消呼叫函數反而產生錯誤