替换相关内容，并重新编号

1005423860

如附件所示，求教。

一把小刀闯天下

'假设H列有序，，，

Option Explicit

Sub test()
  Dim arr, i, j, m, cnt, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a3].CurrentRegion
  For i = 2 To UBound(arr, 1)
    dic(arr(i, 1) & arr(i, 2)) = i
  Next
  arr = [h3].CurrentRegion.Offset(1).Resize(, 5)
  For i = 1 To UBound(arr, 1) - 1
    If Not dic.exists(arr(i, 1) & arr(i, 2)) Then
      m = m + 1
      For j = 1 To UBound(arr, 2)
        arr(m, j) = arr(i, j)
      Next
    End If
  Next
  For i = 1 To m
    cnt = cnt + 1: arr(i, 5) = cnt - 1
    If arr(i, 1) <> arr(i + 1, 1) Or i = m Then cnt = 0
  Next
  If m > 0 Then [t4].Resize(m, UBound(arr, 2)) = arr
End Sub

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     brr = [h3].CurrentRegion.Offset(1)
   
4.     crr = [a3].CurrentRegion
   
5.     arr = [h3].Resize(UBound(brr) + UBound(crr), UBound(brr, 2))
   
6.     For j = 2 To UBound(crr)
   
7.         d(crr(j, 1)) = d(crr(j, 1)) & "," & j
   
8.         d(crr(j, 1) & crr(j, 2)) = j
   
9.     Next j
   
10.     r = 2
    
11.     For j = 1 To UBound(brr) - 1
    
12.         If Not d.exists(brr(j, 1) & brr(j, 2)) Then
    
13.             If brr(j, 1) <> brr(j + 1, 1) Then
    
14.                 For i = 1 To UBound(brr, 2) - 1
    
15.                     arr(r, i) = brr(j, i)
    
16.                 Next i
    
17.                 arr(r, i) = r - 2
    
18.                 r = r + 1
    
19.                 xrr = Split(d(brr(j, 1)), ",")
    
20.                 For x = 1 To UBound(xrr)
    
21.                     For i = 1 To UBound(crr, 2)
    
22.                         arr(r, i) = crr(Val(xrr(x)), i)
    
23.                     Next i
    
24.                     arr(r, 5) = r - 2
    
25.                     r = r + 1
    
26.                 Next x
    
27.                 If d.exists(brr(j, 1)) Then d.Remove brr(j, 1)
    
28.             Else
    
29.                 For i = 1 To UBound(brr, 2)
    
30.                     arr(r, i) = brr(j, i)
    
31.                 Next i
    
32.                 r = r + 1
    
33.                
    
34.             End If
    
35.             
    
36.         End If
    
37.     Next j
    
38.     For j = 0 To d.Count - 1
    
39.         If Len(d.keys()(j)) = 4 Then
    
40.             xrr = Split(d.items()(j), ",")
    
41.             For x = 1 To UBound(xrr)
    
42.                 For i = 1 To UBound(crr, 2)
    
43.                     arr(r, i) = crr(Val(xrr(x)), i)
    
44.                 Next i
    
45.                 arr(r, 5) = r - 2
    
46.                 r = r + 1
    
47.             Next x
    
48.         End If
    
49.     Next j
    
50.     d.RemoveAll
    
51.     For j = 2 To r - 1
    
52.         d(arr(j, 1)) = 1 + d(arr(j, 1))
    
53.         arr(j, UBound(arr, 2)) = d(arr(j, 1)) - 1
    
54.     Next j
    
55.     [t3].Resize(r - 1, UBound(arr, 2)) = arr
    
56. End Sub
    

复制代码

liulang0808

结果放在T列以后，与模拟结果有一行的出入