[已解决]利用VBA 合并[]内的值

hadesqu

求助，请大哥大姐帮忙看下这样的是否能用VBA来实现

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-9-28 17:00

1. Sub aaa()
   
2. Dim arr, brr, crr, d As Object, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 3)
   
6. For i = 1 To UBound(arr)
   
7.   crr = Split(arr(i, 1), "[")
   
8.   If Not d.exists(crr(0)) Then
   
9.     r = r + 1
   
10.     d(crr(0)) = r
    
11.     brr(r, 1) = crr(0)
    
12.   End If
    
13.   If UBound(crr) > 0 Then
    
14.     If brr(d(crr(0)), 2) = "" Then brr(d(crr(0)), 2) = 0
    
15.     If brr(d(crr(0)), 2) > Val(crr(1)) Then brr(d(crr(0)), 2) = Val(crr(1))
    
16.     If brr(d(crr(0)), 3) < Val(crr(1)) Then brr(d(crr(0)), 3) = Val(crr(1))
    
17.   End If
    
18. Next i
    
19. For i = 1 To r
    
20.   If brr(i, 2) <> "" Then brr(i, 1) = "[" & brr(i, 3) & ":" & brr(i, 2) & "] " & brr(i, 1)
    
21. Next i
    
22. [f1].Resize(r) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

如果中间断号怎么处理，比如test有0-8里面缺个5怎么办？

hadesqu

大灰狼1976 发表于 2017-9-28 16:14
如果中间断号怎么处理，比如test有0-8里面缺个5怎么办？

谢谢版大回复
  中间不会有缺的，0-8的话，一定是连续的1，2，3.......7，8.

大灰狼1976

1. Sub aaa()
   
2. Dim arr, brr, crr, d As Object, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 3)
   
6. For i = 1 To UBound(arr)
   
7.   crr = Split(arr(i, 1), "[")
   
8.   If Not d.exists(crr(0)) Then
   
9.     r = r + 1
   
10.     d(crr(0)) = r
    
11.     brr(r, 1) = crr(0)
    
12.   End If
    
13.   If UBound(crr) > 0 Then
    
14.     If brr(d(crr(0)), 2) = "" Then brr(d(crr(0)), 2) = 0
    
15.     If brr(d(crr(0)), 2) > Val(crr(1)) Then brr(d(crr(0)), 2) = Val(crr(1))
    
16.     If brr(d(crr(0)), 3) < Val(crr(1)) Then brr(d(crr(0)), 3) = Val(crr(1))
    
17.   End If
    
18. Next i
    
19. For i = 1 To r
    
20.   If brr(i, 2) <> "" Then brr(i, 1) = "[" & brr(i, 3) & ":" & brr(i, 2) & "] " & brr(i, 1)
    
21. Next i
    
22. [f1].Resize(r) = brr
    
23. End Sub

复制代码

hadesqu

大灰狼1976 发表于 2017-9-28 17:00

感谢，感谢～～这样就OK了

大灰狼1976

有点小问题，修改了一下：
Sub aaa()
Dim arr, brr, crr, d As Object, r&
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 1 To UBound(arr)
  crr = Split(arr(i, 1), "[")
  If Not d.exists(crr(0)) Then
    r = r + 1
    d(crr(0)) = r
    brr(r, 1) = crr(0)
  End If
  If UBound(crr) > 0 Then
    If brr(d(crr(0)), 2) = "" Then brr(d(crr(0)), 2) = Val(crr(1))
    If brr(d(crr(0)), 2) > Val(crr(1)) Then brr(d(crr(0)), 2) = Val(crr(1))
    If brr(d(crr(0)), 3) < Val(crr(1)) Then brr(d(crr(0)), 3) = Val(crr(1))
  End If
Next i
For i = 1 To r
  If brr(i, 3) <> "" Then brr(i, 1) = "[" & brr(i, 3) & ":" & brr(i, 2) & "] " & brr(i, 1)
Next i
[f1].Resize(r) = brr
End Sub