查找连续的数字（继续寻找方法）

aman1516

字符串 t 为：
t = "D18,D15,D22,D23,D24,D25,D12,D11,D10,D7,D4,D3,D27"
各字符代表单元格，无序不规则，如何将其中连续的单元格（t）设置成如下格式：
t = "D3:D4,D7,D10:D12,D15,D18,D22:D25,D27"

附件就不上了，请教下老师如何处理？

3月1日补充：
当字符串存在两种格式时，如：t = "D18,D15,D1:D3,D22,D23,D24,D25,D12,D11,D10,D7,D4,D27:D32"
还是 准提部林 老师的最适用（能排序，唯一缺点是要添加批注，若表格对应单元格有批注时就会产生冲突），
其他的方法在字符串处理时又复杂了许多，若不考虑排序，则还是直接用  Union 方法简单些：

1. Sub t99()
   
2. Dim t As String, rng As Range, ran As Range
   
3. t = "D18,D15,D1:D3,D22,D23,D24,D25,D12,D11,D10,D7,D4,D27:D32"
   
4. For Each ran In Range(t)
   
5.     If rng Is Nothing Then Set rng = ran Else Set rng = Union(rng, ran)
   
6. Next
   
7. MsgBox rng.Address(0, 0)
   
8. End Sub

复制代码

liulang0808

Sub test()
    t = "D18,D15,D22,D23,D24,D25,D12,D11,D10,D7,D4,D3,D27"
   
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "[A-Z]+"
        zm = .Execute(t)(0).Value
        BRR = Split("," & .Replace(t, ""), ",")
    End With


    For i = 1 To UBound(BRR)
        For l = i + 1 To UBound(BRR)
            If Val(BRR(l)) < Val(BRR(i)) Then
                tm = BRR(i)
                BRR(i) = BRR(l)
                BRR(l) = tm
               
            End If
        Next l
    Next i
    str1 = ""
    x = BRR(1)
    y = 1
    For i = 2 To UBound(BRR)
        If Val(BRR(i)) <> Val(BRR(i - 1)) + 1 Then
            If y + 1 <> i Then
                str1 = str1 & "," & zm & x & ":" & zm & BRR(i - 1)
                x = BRR(i)
                y = i
            Else
                str1 = str1 & "," & zm & x
                x = BRR(i)
                y = i
            End If
        End If
    Next i
    If y = UBound(BRR) Then
        str1 = str1 & "," & zm & x
    Else
        str1 = str1 & "," & zm & x & ":" & zm & BRR(UBound(BRR))
    End If

    MsgBox Mid(str1, 2)

  

End Sub

aman1516

liulang0808 发表于 2021-2-28 21:59
Sub test()
    t = "D18,D15,D22,D23,D24,D25,D12,D11,D10,D7,D4,D3,D27"
   

感谢版主出手，正则处理后再排序再组合
非常正确，改成自定义函数就可通用了

lss001

Sub nn()
    t = "D18,D15,D22,D23,D24,D25,D12,D11,D10,D7,D4,D3,D27"
    t = Split(Replace(t, "D", ""), ",")
    Set s = CreateObject("System.Collections.ArrayList")
    For i = 0 To UBound(t): s.Add Val(t(i)): Next
    s.Sort: s.Add 0: r = "D" & s(0)
    For i = 1 To UBound(t)
         If s(i) - s(i - 1) <> 1 Then
            r = r & "," & "D" & s(i)
         Else
            If s(i ) - s(i + 1) <> -1 Then
               r = r & ":" & "D" & s(i)
            Else:  r = r
            End If
         End If
    Next
End Sub

cui26896

Sub try()
Dim arr, brr, i%, j%, t, k%, temp, n%
  arr = [{"D18","D15","D22","D23","D24","D25","D12","D11","D10","D7","D4","D3","D27"}]
  ReDim brr(1 To UBound(arr))
  For i = 1 To UBound(arr)
    brr(i) = Val(Replace(arr(i), "D", ""))
  Next
  Erase arr
    For i = 1 To UBound(brr) - 1
      For j = 1 To UBound(brr) - i
        If brr(j) > brr(j + 1) Then
          t = brr(j): brr(j) = brr(j + 1): brr(j + 1) = t
        End If
      Next
    Next
  For i = 1 To UBound(brr) - 1

      If brr(i + 1) - brr(i) = 1 Then
        n = n + 1
        If n = 1 Then
          temp = "D" & brr(i)
          Else
            temp = temp & ":D" & brr(i)
        End If
      ElseIf brr(i + 1) - brr(i) > 1 Then
        If temp = vbNullString Then
          k = k + 1
          ReDim Preserve arr(1 To k)
          arr(k) = "D" & brr(i)
          Else
            k = k + 1
            ReDim Preserve arr(1 To k)
            arr(k) = temp & ":D" & brr(i)
            n = 0: temp = vbNullString
            If i = UBound(brr) - 1 Then
              k = k + 1
              ReDim Preserve arr(1 To k)
              arr(k) = "D" & brr(i + 1)
            End If
        End If
      End If
  Next
  t = Join(arr, ",")
End Sub

cui26896

lss001老师的代码怎么给删除了，写得非常好！既简练又实用，让我了解了不少，只是有一个小小的笔误，稍微知道点的人都不会在意。

lss001

cui26896 发表于 2021-3-1 10:49
lss001老师的代码怎么给删除了，写得非常好！既简练又实用，让我了解了不少，只是有一个小小的笔误，稍微知 ...

优化一下，正在审核，稍后......

准提部林

取巧法...利用"註解"重新抓位置,
可連續列 或 跨列:
Sub TEST()
Dim T$, Rng As Range, A As Range
T = "D18,D15,D22,D23,D24,D25,D12,D10,D11,D7,D4,D3,D27"
Set Rng = Range(T)
For Each A In Rng
    A.NoteText "test"
Next
With Rng.EntireColumn
     T = .SpecialCells(xlCellTypeComments).Address(0, 0)
     .ClearComments
End With
MsgBox T
End Sub

cui26896

准提部林 发表于 2021-3-1 12:19
取巧法...利用"註解"重新抓位置,
可連續列 或 跨列:
Sub TEST()

准部老师加注释，取得有注释单元格地址的方法太新颖了！不得不点赞！！

aman1516

准提部林 发表于 2021-3-1 12:19
取巧法...利用"註解"重新抓位置,
可連續列 或 跨列:
Sub TEST()

向各位老师学习，这个方法太绝妙了，必须赞一个！