Option Explicit
Sub TEST()
Dim Brr, Crr, Z, Q, i&, j%, v&, Y, T$, R&, n%, vD$, xU As Range, w&, xA As Range, Zn%
Set Z = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set xA = [結果!A1]
If Not IsDate([H1]) Then MsgBox "先輸入正確糧期": [H1].Activate: Exit Sub
vD = Format([H1], "YYYY/MM")
Brr = Range([D1], Cells(Rows.Count, "A").End(3))
For i = 2 To UBound(Brr)
If Brr(i, 1) = "" Then GoTo i01 Else Y(Brr(i, 1)) = 0
If Format(Brr(i, 3), "YYYY/MM") <> vD Then GoTo i01
If Brr(i, 2) = "NPSL" Then Z(Brr(i, 2) & Brr(i, 3)) = Brr(i, 3): GoTo i01
R = R + 1: For j = 1 To 4: Brr(R, j) = Brr(i, j): Next
i01: Next
Zn = Z.Count: If Zn = 0 Then MsgBox vD & " 糧期沒有 NPSL 的資料": Exit Sub
If R = 0 Then MsgBox "沒有吻合糧期的資料": Exit Sub
With Sheets("結果").[A1].Resize(R, 4)
Union(.Cells, .Offset(0, 2)).EntireColumn.Clear
.Value = Brr
.Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(3), Order2:=1, Header:=2
.Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(2), Order2:=1, Header:=2
Brr = .Value: .Clear
End With
For i = 1 To UBound(Brr)
T = Brr(i, 1):
If Y(T & "|") = "" Then Y(T & "|") = i Else Y(T) = Y(T) + 1
Next
Set xU = xA
For Each Q In Y.keys
If InStr(Q, "|") Then Exit For
Set xU = Union(xU, xA.Offset(w, 0))
w = w + 8 + Y(Q) + Zn: If Y(Q) Then w = w + 3
Next
[F1:K45].Copy xU: Application.Goto xA
Set xA = [A1].Resize(w, 6)
For i = 7 To 10: xA.Borders(i).Weight = 4: Next
Crr = xA
w = 0
For Each Q In Y.keys
If InStr(Q, "|") Then Exit For
v = 2 + w
Crr(v, 3) = Q
v = v + 5
If Y(Q) Then
For i = Y(Q & "|") To Y(Q & "|") + Y(Q)
v = v + 1: For j = 2 To 4: Crr(v, j) = Brr(i, j): Next
Next
End If
For i = 1 To Zn
n = IIf(Y(Q), 2, 0): n = n + v + i
Crr(n, 2) = "NPSL": Crr(n, 3) = Z.Items()(i - 1): Crr(n, 4) = 1
Next
w = w + 8 + Y(Q) + Zn: If Y(Q) Then w = w + 3
Next
xA = Crr
Set Z = Nothing: Erase Brr, Crr
End Sub
