­ã´£³¡ªL

¦^´_ 9# 198188

Sub Test()
Dim Arr, Brr, Crr, xD, T$, V, i&, j%, k%, U&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range(Sheets("Read").[m1], Sheets("Read").[a65536].End(3))
Brr = Range(Sheets("Data Base").[m1], Sheets("Data Base").[a65536].End(3))
'----------------------------------
ReDim Crr(1 To UBound(Brr), 1 To UBound(Brr, 2))
N = 2: Crr(N, 1) = "'==( Round-" & k + 1 & " )======"
For j = 1 To UBound(Arr, 2): Crr(N - 1, j) = Arr(1, j): Next
'-----------------------------------
For i = 2 To UBound(Arr)
    T = Arr(i, 1): V = Val(Arr(i, 3)): U = xD(T & "+" & k)
    If U = 0 Then
       N = N + 1: U = N: xD(T & "+" & k) = N: V = 0
       For j = 1 To UBound(Arr, 2): Crr(N, j) = Arr(i, j): Next
    End If
    Crr(U, 3) = Crr(U, 3) + V
    xD(T & "/" & k) = Crr(U, 3)
Next i
'------------------------------
For k = 1 To 2
    N = N + 1: Crr(N, 1) = "'==( Round-" & k + 1 & " )======"
    For i = 2 To UBound(Brr)
        T = Brr(i, 8): V = Val(Brr(i, 3)): U = xD(T & "/" & k - 1)
        If U > 0 Then
           N = N + 1: T = Brr(i, 1)
           For j = 1 To UBound(Brr, 2): Crr(N, j) = Brr(i, j): Next
           Crr(N, 3) = V * U
           xD(T & "/" & k) = xD(T & "/" & k) + V * U
        End If
    Next i
Next k
'------------------------------
With Sheets("Test")
     .UsedRange.EntireRow.Delete
     .[a1].Resize(N, UBound(Crr, 2)) = Crr
     Application.Goto .[a1]
End With
Beep
End Sub

Xl0000322.rar (22.32 KB)

¤U¸ü¦¸¼Æ: 0

7 ¤p®É«e