GBKEE

¦^´_ 12# luke

1. Option Explicit
   
2. Sub Ex°}¦C()
   
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¦r¨åª«¥ó()
    
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

½Æ»s¥N½X