register313

回復 10# luke

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

luke

回復 11# register313


    謝謝回覆

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

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

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

以上說明

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

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

複製代碼

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

複製代碼