压缩连续数（含单双）

高个子

这题先按照不间断的单双数压缩，再按照连续数压缩，我现在希望用VBA来解决，详细见附件

PS：这题是我根据某大学的课表想到的，然后参考了静版的数据源，根据课表的格式自己增加了一些变成数据源，按照自己的规则手动做出结果
我看到的课表中一个单元格内有好几个信息：课程/周次/地点/教师/教学班组成/选课人数，可能还有多个课程
某个单元格写的是(3-4节)2-8周,12-14周(双),15-17周，后面标记单双是指单双周上课，周次这个格式让我眼前一亮
然后我联想到这个和之前静版的题类似但是有区别，故简化以后给大家做做
【练习小题】压缩连续数-Excel函数与公式-ExcelHome技术论坛 -

chxw68

1. Sub test()
   
2.     Dim r%, i%, m%
   
3.     Dim arr, brr, zrr()
   
4.     With Worksheets("题目")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("a2:a" & r)
   
7.         ReDim brr(1 To UBound(arr), 1 To 1)
   
8.         For i = 1 To UBound(arr)
   
9.             xm = Split(arr(i, 1), ",")
   
10.             m = 1
    
11.             ReDim zrr(1 To m)
    
12.             zrr(m) = Array(0, 0, -1)
    
13.             For j = 1 To UBound(xm)
    
14.                 If Val(xm(j)) = Val(xm(j - 1)) + 1 Then
    
15.                     If zrr(m)(2) = -1 Or zrr(m)(2) = 1 Then
    
16.                         zrr(m)(1) = j
    
17.                         zrr(m)(2) = 1
    
18.                     Else
    
19.                         m = m + 1
    
20.                         ReDim Preserve zrr(1 To m)
    
21.                         zrr(m) = Array(j, j, -1)
    
22.                     End If
    
23.                 ElseIf Val(xm(j)) = Val(xm(j - 1)) + 2 Then
    
24.                     If zrr(m)(2) = -1 Or zrr(m)(2) = 2 Then
    
25.                         zrr(m)(1) = j
    
26.                         zrr(m)(2) = 2
    
27.                     Else
    
28.                         m = m + 1
    
29.                         ReDim Preserve zrr(1 To m)
    
30.                         zrr(m) = Array(j, j, -1)
    
31.                     End If
    
32.                 Else
    
33.                     m = m + 1
    
34.                     ReDim Preserve zrr(1 To m)
    
35.                     zrr(m) = Array(j, j, -1)
    
36.                 End If
    
37.             Next
    
38.             For k = 1 To UBound(zrr)
    
39.                 If zrr(k)(0) = zrr(k)(1) Then
    
40.                     brr(i, 1) = brr(i, 1) & "," & xm(zrr(k)(0))
    
41.                 Else
    
42.                     If zrr(k)(2) = 1 Then
    
43.                         brr(i, 1) = brr(i, 1) & "," & xm(zrr(k)(0)) & "-" & xm(zrr(k)(1))
    
44.                     Else
    
45.                         If xm(zrr(k)(0)) Mod 2 = 1 Then
    
46.                             brr(i, 1) = brr(i, 1) & "," & xm(zrr(k)(0)) & "-" & xm(zrr(k)(1)) & "(单)"
    
47.                         Else
    
48.                             brr(i, 1) = brr(i, 1) & "," & xm(zrr(k)(0)) & "-" & xm(zrr(k)(1)) & "(双)"
    
49.                         End If
    
50.                     End If
    
51.                 End If
    
52.             Next
    
53.         Next
    
54.         For i = 1 To UBound(brr)
    
55.             If brr(i, 1) <> Empty Then
    
56.                 brr(i, 1) = Mid(brr(i, 1), 2)
    
57.             End If
    
58.         Next
    
59.         .Range("c2").Resize(UBound(brr), 1) = brr
    
60.     End With
    
61. End Sub
    

复制代码

chxw68

详见附件。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        br = Split(ar(i, 1), ",")
        ReDim cr(0 To UBound(br))
        For j = 0 To UBound(br)
            cr(j) = br(j)
        Next j
        br = JoinConsecutiveNums(cr, "-")
        ar(i, 3) = Join(br, ",")
    Next i
   
    [A11].Resize(UBound(ar), UBound(ar, 2)) = ar
    Beep
End Sub
Function JoinConsecutiveNums(ar, strSymbol$) As Variant
    Dim br(), cr, iStart&, i&, r&
   
    ReDim Preserve ar(LBound(ar) To UBound(ar) + 1)
    iStart = ar(LBound(ar))
    For i = LBound(ar) + 1 To UBound(ar)
       If ar(i) - ar(i - 1) <> 1 Then
          r = r + 1
          ReDim Preserve br(1 To r)
          br(r) = iStart & strSymbol & ar(i - 1)
          iStart = ar(i)
       End If
    Next i
    For i = 1 To UBound(br)
        cr = Split(br(i), strSymbol)
        If cr(0) = cr(1) Then br(i) = cr(0)
    Next i
    JoinConsecutiveNums = br
End Function

gwjkkkkk

参与一下。。。

cnmlgb9998

用PQ 解决。。。。。


PQ难道不香么？？？？？？？？？？

数据增减修改，能自动刷 新 结果 。

sunya_0529

WPS里的JSA练习一下——

笨鸟飞不高

压缩连续数（含单双）.rar (17.4 KB, 下载次数: 2)

2024-9-17 16:36 上传

点击文件名下载附件

修改一下！

高个子

统一回复：感谢各位解答