麻辣家族討論版版 - Powered by Discuz! Board

Sub ex()
Dim Ar(), A As Range, C As Range, B As Range
Set d = CreateObject("Scripting.Dictionary")
With sheet2
For Each A In .Range(.[D2], .[D2].End(xlDown))
x = A & A.Offset(, 1)
For Each C In .Range(.[F1], .[F1].End(xlToRight))
d(x & C) = .Cells(A.Row, C.Column)
Next
Next
End With
With sheet1
For Each A In .Range(.[A1], .[A1].End(xlDown))
Set B = A.Resize(, 4)
p = IIf(d(B(1) & B(2) & B(3)) = "", Replace(B(2), "X", ""), d(B(1) & B(2) & B(3)))
n = IIf(d(B(1) & B(2) & B(4)) = "", Replace(B(2), "X", ""), d(B(1) & B(2) & B(4)))
A.Offset(, 5).Resize(, 4) = Array(B(1), B(2), p, n)
Next
End With
End Sub

複製代碼

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

複製代碼

Option Explicit
Sub Ex陣列()
Dim Ar1(), Ar2(), A As Range, S As Variant, xR(1 To 2)
S = 1
With sheet2
For Each A In .Range(.[D2], .[D2].End(xlDown))
ReDim Preserve Ar1(1 To S)
ReDim Preserve Ar2(1 To S)
Ar1(S) = A & A.Cells(1, 2)
Ar2(S) = .Range(A.Cells(1, 3), A.Cells(1, 2).End(xlToRight)).Value
Ar2(S) = Application.Transpose(Application.Transpose(Ar2(S)))
S = S + 1
Next
End With
With sheet1
For Each A In .Range(.[A1], .[A1].End(xlDown))
S = Application.Match(A & A(1, 2), Ar1, 0)
If Not IsError(S) Then
xR(1) = A(1, 3)
xR(2) = A(1, 4)
If IsNumeric(A(1, 3)) Then If A(1, 3).Value + 1 <= UBound(Ar2(S)) Then xR(1) = Ar2(S)(A(1, 3) + 1)
If IsNumeric(A(1, 4)) Then If A(1, 4).Value + 1 <= UBound(Ar2(S)) Then xR(2) = Ar2(S)(A(1, 4) + 1)
A.Offset(, 5).Resize(, 4) = Array(A, A(1, 2), xR(1), xR(2))
Else
A.Offset(, 5).Resize(, 4) = A.Resize(, 4).Value
End If
Next
End With
End Sub
Sub Ex字典物件()
Dim d As Object, Ar(), A As Range, C As Range, B As Range, x As String
Set d = CreateObject("Scripting.Dictionary")
With sheet2
For Each A In .Range(.[D2], .[D2].End(xlDown))
x = A & A.Cells(1, 2)
For Each C In .Range(A.Cells(1, 3), A.Cells(1, 2).End(xlToRight))
If d.Exists(x) Then
Ar = d(x)
ReDim Preserve Ar(UBound(Ar) + 1)
Ar(UBound(Ar)) = C.Value
d(x) = Ar
Else
d(x) = Array(C.Value)
End If
Next
Next
End With
With sheet1
For Each A In .Range(.[A1], .[A1].End(xlDown))
If d.Exists(A & A(1, 2)) Then
ReDim Ar(2)
Ar(0) = d(A & A(1, 2))
If A(1, 3) <= UBound(Ar(0)) Then Ar(1) = Ar(0)(A(1, 3)) Else Ar(1) = A(1, 3)
If A(1, 4) <= UBound(Ar(0)) Then Ar(2) = Ar(0)(A(1, 4)) Else Ar(2) = A(1, 4)
A.Offset(, 5).Resize(, 4) = Array(A, A(1, 2), Ar(1), Ar(2))
Else
A.Offset(, 5).Resize(, 4) = A.Resize(, 4).Value
End If
Next
End With
End Sub

複製代碼