将一组掺杂着连续和不连续的以顿号隔开的序号组修改成序号1-序号n、序号n+1-序号n+...

疯泠风

将一组掺杂着连续和不连续的以顿号隔开的序号组修改成序号1-序号n、序号n+1-序号n+n这样
哪位大佬帮帮忙呀。感激不尽

chxw68

练练手。。

gwjkkkkk

参与一下。。。

micch

mark一下，居然老能见到这种拆分合并的需求，回头试试

吴中泉

我能想到的笨办法 TEST.rar (13.09 KB, 下载次数: 6)

2023-6-27 21:24 上传

点击文件名下载附件

吴中泉

1. Sub ssjss() '2023.6.27 wzq
   
2. Dim arr, brr(1), i, j, s1, s2
   
3. j = 1
   
4. For Each Cell In Range("A2:I2")
   
5. arr = Split(Cell.Value, "编号")
   
6. For i = 1 To UBound(arr) + 1
   
7.      On Error Resume Next
   
8.      s1 = arr(i - 1): s2 = arr(i)
   
9.     If s1 <> "" Then
   
10.        If Val(s1) = Val(s2) - 1 Then
    
11.             brr(n) = "编号" & Replace(s1, "、", "")
    
12.             n = 1: arr(i - 1) = ""
    
13.         Else
    
14.             If brr(0) <> "" Then
    
15.                 arr(i - 1) = brr(0) & "-编号" & arr(i - 1)
    
16.             Else
    
17.                 arr(i - 1) = "编号" & arr(i - 1)
    
18.             End If
    
19.             n = 0: brr(0) = "": brr(1) = ""
    
20.         End If
    
21.     End If
    
22. Next
    
23. Cells(5, j) = Trim(Join(arr)): j = j + 1
    
24. Next
    
25. End Sub
    

复制代码

micch

1. 
   
2. Sub test()
   
3.     Dim ar(), br(), x$, k%
   
4.     ar = Range("a2:i2").Value
   
5.     ReDim br(1 To 2, 1 To 9)
   
6.    
   
7.     For k = 1 To 9
   
8.         x = Mid(ar(1, k), 3)
   
9.         x = MergeString(x, "、编号")
   
10.         br(1, k) = "编号" & x
    
11.         br(2, k) = "编号" & ExpandString(x, "、编号", "-编号")
    
12.     Next
    
13.     Range("a5:i6").Value = br
    
14. End Sub
    
15. 
    
16. Function MergeString(str0$, s0$) As String
    
17.     Dim ar, br, i%, j%, k%, t, s1
    
18.     ar = Split(VBA.StrConv(str0, vbNarrow), VBA.StrConv(s0, vbNarrow))
    
19.     s1 = "-" & Mid(s0, 2)
    
20.     ReDim br(0 To UBound(ar))
    
21.     'SortArray ar
    
22.     For i = 0 To UBound(ar)
    
23.         t = Val(ar(i))
    
24.         If i = 0 Then
    
25.             br(0) = ar(i)
    
26.             j = 0
    
27.         ElseIf i = UBound(ar) Then
    
28.             If t - Val(ar(i - 1)) = 1 Then
    
29.                 br(i) = s1 & ar(i)
    
30.             Else
    
31.                 br(i) = s0 & ar(i)
    
32.             End If
    
33.         ElseIf t - Val(ar(i - 1)) <> 1 Then
    
34.             If i - 1 = j Then
    
35.                 br(i) = s0 & ar(i)
    
36.             Else
    
37.                 br(i - 1) = s1 & ar(i - 1)
    
38.                 br(i) = s0 & ar(i)
    
39.             End If
    
40.             j = i
    
41.         End If
    
42.     Next
    
43.     MergeString = Join(br, "")
    
44. End Function
    
45. Function ExpandString(str0$, s0$, s1$) As String
    
46.     Dim ar, br, x, s$, i%
    
47.     ar = Split(str0, s0)
    
48.     For Each x In ar
    
49.         br = Split(x & s1 & x, s1)
    
50.         For i = Val(br(0)) To Val(br(1))
    
51.             s = s & s0 & Format(i, "00")
    
52.         Next
    
53.     Next
    
54.     ExpandString = Mid(s, Len(s0) + 1)
    
55. End Function
    
56. Function SortArray(ar)
    
57. 
    
58. End Function
    

复制代码

LIUZHU

JS宏来凑一波热闹，这个问题还有点绕

LIUZHU

附件请参考，WPS测试

笨鸟飞不高

TEST.zip (15.1 KB, 下载次数: 6)

2023-6-28 11:40 上传

点击文件名下载附件