求助：连续票号统计

E_T⊙_⊙TE

求助各位大神：

需求，自动统计连续票号的起止号及数量.
哪位老师帮忙写个代码

边缘码农

数据很有规律嘛。

半百

写的有点啰嗦

小凡、、、

循环判断后七位是否连续

心的启点

测试后反馈

联系票号统计.rar (32.6 KB, 下载次数: 10)

2024-6-28 15:01 上传

点击文件名下载附件

Qs18

Sub qs() '2024/6/28
    With Sheet1
    .Range("j4:z10000").Clear
        arr = Range("b4:b" & Cells(Rows.Count, 2).End(3).Row)
        ReDim brr(1 To UBound(arr), 1 To 4)
        brr(1, 1) = arr(1, 1)
        brr(1, 4) = 1
        brr(1, 3) = arr(1, 1)
        m = 1
        For i = 2 To UBound(arr)
            If Right(arr(i, 1), 7) - Right(arr(i - 1, 1), 7) = 1 Then
                brr(m, 3) = arr(i, 1)
                brr(m, 2) = "—"
                brr(m, 4) = brr(m, 4) + 1
            Else
                m = m + 1
                brr(m, 1) = arr(i, 1)
                brr(m, 2) = "—"
                brr(m, 3) = arr(i, 1)
                brr(m, 4) = 1
            End If
        Next
        With .[j4].Resize(m, 4)
            .Value = brr
            .Borders.LineStyle = 1
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    End With
    MsgBox "完成!"
End Sub

Qs18

试试................

Qs18

试试.............

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.28
   
2.     Application.ScreenUpdating = False
   
3.     r = Cells(Rows.Count, 2).End(3).Row
   
4.     arr = [b1].Resize(r, 1)
   
5.     ReDim brr(1 To UBound(arr), 1 To 4)
   
6.     bt = Left(arr(4, 1), 6)
   
7.     For i = 4 To UBound(arr) - 1
   
8.         n = n + 1
   
9.         m1 = Val(Mid(arr(i, 1), 7))
   
10.         If n = 1 Then st1 = m1
    
11.         m2 = Val(Mid(arr(i + 1, 1), 7))
    
12.         If m2 - m1 <> 1 Then
    
13.             m = m + 1
    
14.             brr(m, 1) = bt & st1
    
15.             brr(m, 2) = "-"
    
16.             brr(m, 3) = bt & m1
    
17.             brr(m, 4) = n
    
18.             n = 0
    
19.         End If
    
20.     Next
    
21.     [j4:m1000].Clear
    
22.     [j4].Resize(m, 4) = brr
    
23.     [j3].Resize(1, 4).Interior.Color = 49407
    
24.     With [j4].Resize(m, 4)
    
25.         .Value = brr
    
26.         .Borders.LineStyle = 1
    
27.         .HorizontalAlignment = xlCenter
    
28.         .VerticalAlignment = xlCenter
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码