Option Explicit
Sub Test_a1()
Dim Arr, Brr(1 To 10000, 1 To 10), xD, T$, i&, j%, N&, R&
Sheets("Result").UsedRange.ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([Inventor!x1], [Inventor!a65536].End(3))
For i = 4 To UBound(Arr)
If Not IsNumeric(Arr(i, 1) & "") Then GoTo i01
T = Arr(i, 3) & "\" & Arr(i, 4) & "\" & Arr(i, 9) & "\" & Arr(i, 10) & "\" & Arr(i, 11)
R = xD(T)
If R = 0 Then
N = N + 1: xD(T) = N: Brr(N, 1) = N: R = N
For j = 2 To 10
Brr(N, j) = Arr(i, Val(Split("//3/4/5/6/8/9/10/11/12", "/")(j)))
Next
GoTo i01
End If
Brr(R, 5) = Val(Brr(R, 5)) + Val(Arr(i, 6))
Brr(R, 6) = Val(Brr(R, 6)) + Val(Arr(i, 8))
Brr(R, 10) = Val(Brr(R, 10)) + Val(Arr(i, 12))
i01: Next i
If N = 0 Then Exit Sub
With [Result!a2:J2].Resize(N)
.Rows(1).Copy .Cells
.Value = Brr
.Columns(2).Resize(, 9).Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
End With
End Sub作者: mdr0465 時間: 2024-8-1 12:22
Sub Test_a1()
Dim Arr, Brr(1 To 10000, 1 To 10), xD, T$, i&, j%, N&, R&
Sheets("Result").UsedRange.ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([Inventor!x1], [Inventor!a65536].End(3))
For i = 4 To UBound(Arr)
If Not IsNumeric(Arr(i, 1) & "") Then GoTo i01
T = Arr(i, 3) & "\" & Arr(i, 4) & "\" & Arr(i, 9) & "\" & Arr(i, 10) & "\" & Arr(i, 11)
R = xD(T)
If R = 0 Then
N = N + 1: xD(T) = N: Brr(N, 1) = N: R = N
For j = 2 To 10
Brr(N, j) = Arr(i, Val(Split("//3/4/5/6/8/9/10/11/12", "/")(j)))
Next
GoTo i01
End If
Brr(R, 5) = Val(Brr(R, 5)) + Val(Arr(i, 6))
Brr(R, 6) = Val(Brr(R, 6)) + Val(Arr(i, 8))
Brr(R, 10) = Val(Brr(R, 10)) + Val(Arr(i, 12))
i01: Next i
If N = 0 Then Exit Sub
With [Result!a2:J2].Resize(N)
.Rows(1).Copy .Cells
.Value = Brr
.Columns(2).Resize(, 9).Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
End With
End Sub