求各位大神帮忙解决下同类合并问题

ykcbf1100

jjmysjg 发表于 2023-3-16 12:43
大师，修改的代码怎么改的。谢谢

这里可以不修改。

准提部林

1個字典/1個數組/1次迴圈...完成
Sub TEST_A1()
Dim Arr, xD, T$, T1$, T2$, R&, N&, i&, j%
Set xD = CreateObject("scripting.dictionary")
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): T2 = Arr(i, 2): T = T1 & "/" & T2
    R = xD(T1): xD(T) = xD(T) + 1
    If R = 0 Then
       For j = 1 To 4: Arr(N + 2, j) = Arr(i, j): Next
       N = N + 1:  xD(T1) = N + 1: GoTo i01
    End If
    For j = 3 To 4: Arr(R, j) = Arr(R, j) + Arr(i, j): Next
    If xD(T) = 1 Then Arr(R, 2) = Arr(R, 2) & "、" & Arr(i, 2)
i01: Next i
[f2].Resize(N + 1, 4) = Arr
End Sub