[發問] 如何找出特定數值所對應的儲存格內容

luke

各位大大

小弟有乙個檔案是直接匯入sheet1後, 利用A/B兩欄所產生的修改前/後數值(C欄和D欄),

再去比對sheet2的D:V欄(其中F1:V1代表0-16數字)找出該欄所對應的儲存格,

按下乙個按鈕後, 將比對結果轉換(如附檔說明).

煩請先進指導

TEST7.rar (22.97 KB)

下載次數: 19

2012-4-5 23:18

GBKEE

回復 12# luke

1. Option Explicit
   
2. Sub Ex陣列()
   
3.     Dim Ar1(), Ar2(), A As Range, S As Variant, xR(1 To 2)
   
4.     S = 1
   
5.     With sheet2
   
6.         For Each A In .Range(.[D2], .[D2].End(xlDown))
   
7.             ReDim Preserve Ar1(1 To S)
   
8.             ReDim Preserve Ar2(1 To S)
   
9.             Ar1(S) = A & A.Cells(1, 2)
   
10.             Ar2(S) = .Range(A.Cells(1, 3), A.Cells(1, 2).End(xlToRight)).Value
    
11.             Ar2(S) = Application.Transpose(Application.Transpose(Ar2(S)))
    
12.             S = S + 1
    
13.         Next
    
14.     End With
    
15.     With sheet1
    
16.         For Each A In .Range(.[A1], .[A1].End(xlDown))
    
17.             S = Application.Match(A & A(1, 2), Ar1, 0)
    
18.             If Not IsError(S) Then
    
19.                 xR(1) = A(1, 3)
    
20.                 xR(2) = A(1, 4)
    
21.                 If IsNumeric(A(1, 3)) Then If A(1, 3).Value + 1 <= UBound(Ar2(S)) Then xR(1) = Ar2(S)(A(1, 3) + 1)
    
22.                 If IsNumeric(A(1, 4)) Then If A(1, 4).Value + 1 <= UBound(Ar2(S)) Then xR(2) = Ar2(S)(A(1, 4) + 1)
    
23.                 A.Offset(, 5).Resize(, 4) = Array(A, A(1, 2), xR(1), xR(2))
    
24.             Else
    
25.                 A.Offset(, 5).Resize(, 4) = A.Resize(, 4).Value
    
26.             End If
    
27.         Next
    
28.     End With
    
29. End Sub
    
30. 
    
31. Sub Ex字典物件()
    
32.     Dim d As Object, Ar(), A As Range, C As Range, B As Range, x As String
    
33.     Set d = CreateObject("Scripting.Dictionary")
    
34.     With sheet2
    
35.         For Each A In .Range(.[D2], .[D2].End(xlDown))
    
36.             x = A & A.Cells(1, 2)
    
37.             For Each C In .Range(A.Cells(1, 3), A.Cells(1, 2).End(xlToRight))
    
38.                 If d.Exists(x) Then
    
39.                     Ar = d(x)
    
40.                     ReDim Preserve Ar(UBound(Ar) + 1)
    
41.                     Ar(UBound(Ar)) = C.Value
    
42.                     d(x) = Ar
    
43.                 Else
    
44.                     d(x) = Array(C.Value)
    
45.                 End If
    
46.             Next
    
47.         Next
    
48.     End With
    
49.     With sheet1
    
50.         For Each A In .Range(.[A1], .[A1].End(xlDown))
    
51.             If d.Exists(A & A(1, 2)) Then
    
52.                 ReDim Ar(2)
    
53.                 Ar(0) = d(A & A(1, 2))
    
54.                 If A(1, 3) <= UBound(Ar(0)) Then Ar(1) = Ar(0)(A(1, 3)) Else Ar(1) = A(1, 3)
    
55.                 If A(1, 4) <= UBound(Ar(0)) Then Ar(2) = Ar(0)(A(1, 4)) Else Ar(2) = A(1, 4)
    
56.                 A.Offset(, 5).Resize(, 4) = Array(A, A(1, 2), Ar(1), Ar(2))
    
57.             Else
    
58.                 A.Offset(, 5).Resize(, 4) = A.Resize(, 4).Value
    
59.             End If
    
60.         Next
    
61.     End With
    
62. End Sub

複製代碼

register313

回復 10# luke

用了雙層迴圈,執行效能不佳(若資料有上萬筆,我的雙核電腦跑了約20秒)
參考用

1. Sub zz()
   
2. Application.ScreenUpdating = False
   
3. With sheet1
   
4. .Columns("A:B").Copy .Columns("F:G")
   
5. .Columns("H:I") = ""
   
6. Max = sheet2.[F1].End(xlToRight).Value
   
7. For Each S In .Range(.[A1], .[A1].End(xlDown))
   
8.   For Each T In sheet2.Range(sheet2.[D2], sheet2.[D2].End(xlDown))
   
9.     If S & S.Offset(0, 1) = T & T.Offset(0, 1) Then
   
10.        If Val(S.Offset(0, 2)) <= Max And Val(S.Offset(0, 3)) <= Max Then
    
11.           S.Offset(0, 7) = sheet2.Cells(T.Row, S.Offset(0, 2) + 6)
    
12.           S.Offset(0, 8) = sheet2.Cells(T.Row, S.Offset(0, 3) + 6)
    
13.        End If
    
14.        Exit For
    
15.     End If
    
16.   Next
    
17.   If S.Offset(0, 7) = "" Then S.Offset(0, 2).Resize(1, 2).Copy S.Offset(0, 7)
    
18. Next
    
19. End With
    
20. Application.ScreenUpdating = True
    
21. MsgBox "執行完畢"
    
22. End Sub

複製代碼

luke

回復 11# register313


    謝謝回覆

先前朋友介紹從別的論壇就知道H超版大功力, 小弟是沒有任何懷疑

這次改變是因為原先sheet1表B欄是採物件號碼作處理, 因此測試OK

現在因資料改為物件地址採十六進位才會有比較上錯誤

以上說明

煩請大大, 先進指導, 謝謝!

register313

回復 10# luke

"路人甲"多嘴
先就事論事
1.  2#  Hsieh超版 已用VBA回答您 1#之提問
      若功能有錯誤或不符您的需求
      就應即時反應,而您在4#是答覆"測試OK"
2.  論壇上超版,版主在EXCEL一般區,程式區上之功力無庸置疑
     "路人甲"不擔心超版,版主回答不出問題,只要超版,版主有時間,發問者的提問能讓超版,版主了解功能需求,都是花了時間,盡心盡力的回答
     "路人甲"在意的是發問者的提問 題目不清楚 太竉統 不附檔案 反反覆覆
3. 發帖後,每一層樓之提問,答題都應有一定的順序
    不然會讓看帖的人誤解,也會沒有效率

luke

回復 9# register313


register313大大

謝謝您的回答, 我碰到的問題如下；
1.H超版的程式是對sheet1 的B欄參數特定數值進行替代，若B欄的數值預設為十六進位(非特定值)時, 會產生程式判斷上錯誤，請參考附檔紅色標示, 正確應為粉紅色標示。
2.若sheet1表C/D兩欄的修改前/後數字為空白時, 也會產生程式判斷上錯誤如第13列紅字。
3.若sheet1表A欄為數字100時, 也會產生程式判斷上錯誤如第14+15列紅字”oo”。

煩請先進指導如何修改程式
不勝感激!
TEST7-1.rar (13.15 KB)

下載次數: 8

2012-4-13 09:33

register313

回復 8# luke

於工作表使用陣列公式發現一個問題 "若資料超過1萬筆時,電腦變慢跑不動"
那用VBA的方式寫陣列公式於工作表還不是一樣,換湯不換藥
=>都是用了陣列公式

使用2# Hsieh超版的VBA程式吧(一般使用VBA比較少在工作表寫入公式)

luke

回復 5# luke


    register313大大, 各位先進

     今天測式陣列公式發現一個問題 "若資料超過1萬筆時,電腦變慢跑不動"

      請問如何放入陣列公式於VBA中?

      煩請先進不吝指導 謝謝!

luke

回復 6# register313

測試OK
   
謝謝register313

register313

回復 5# luke

陣列公式
輸入好公式 要按組合鍵Ctrl+Shift+Enter來作確定
原公式的前後會自動加上{ }