Ersetzen Sie fortlaufende Nummern durch einen Bereich

Question

Wie kann ich in einer Zelle fortlaufende Nummern finden und sie durch einen Bereich ersetzen?
Zum Beispiel:

Änderung:

1,3,5,15,16,17,25,28,29,31 ...

zu:

1,3,5,15-17,25,28-29,31 ...

Die Nummern sind bereits sortiert, d.h. in aufsteigender Reihenfolge.

Danke.

Answer 1

Eine interessante Frage, die ich tun, ohne Schleife durch eine Sequenz aussehen wollte für sequentielle Überprüfung (die erste müßte Sortierung) baut

Diese Funktion

1. den String in eine Reihe Adresse zwingt
2. verwendet Union zur Gruppe aufeinanderfolgenden Reihen zusammen
3. die Zeichenfolge manipuliert die Spaltenbezeichner

zu entfernen

Schleife war nicht erforderlich, kürzere Version!

Function NumOut(strIn As String) As String 
Dim rng1 As Range 
Set rng1 = Range("A" & Join(Split(Application.Trim([a1]), ", "), ",A")) 
'force the range into areas rather than cells 
Set rng1 = Union(rng1, rng1) 
NumOut = Replace(Replace(Replace(rng1.Address, "$A$", vbNullstring), ": ", "-"), ",", ", ") 
End Function 

Answer 2

Während der gegebene Bereich/Bereich basierend Antwort interessant ist, leidet es an ein paar Mängel:

• Es beschränkt sich auf einer Eingabezeichenfolge von 255 Zeichen
• Es ist relativ langsam

Hier ist eine grundlegende Array-Loop-basierte Methode. Es kann lange Strings verarbeiten. In meinen Tests läuft es in etwa 1/3 der Zeit. Es hat auch den Vorteil, dass die Eingabe nicht sortiert werden muss.

Function NumOut2(strIn As String) As String 
    Dim arrIn() As String 
    Dim arrBuckets() As Long 
    Dim i As Long 
    Dim InRange As Boolean 
    Dim mn As Long, mx As Long 

    arrIn = Split(strIn, ", ") 
    mn = arrIn(0) 
    mx = arrIn(0) 
    For i = 1 To UBound(arrIn) 
     If arrIn(i) < mn Then 
      mn = arrIn(i) 
     ElseIf arrIn(i) > mx Then 
      mx = arrIn(i) 
     End If 
    Next 

    ReDim arrBuckets(mn To mx) 
    For i = 0 To UBound(arrIn) 
     arrBuckets(arrIn(i)) = arrIn(i) 
    Next 
    NumOut2 = LBound(arrBuckets) 
    InRange = False 
    For i = LBound(arrBuckets) + 1 To UBound(arrBuckets) 
     If arrBuckets(i) > 0 Then 
      If arrBuckets(i) = arrBuckets(i - 1) + 1 Then 
       If InRange Then 

       Else 
        InRange = True 
        NumOut2 = NumOut2 & "-" 
       End If 
      Else 
       If InRange Then 
        NumOut2 = NumOut2 & arrBuckets(i - 1) & ", " & arrBuckets(i) 
       Else 
        NumOut2 = NumOut2 & ", " & arrBuckets(i) 
       End If 
      End If 
     Else 
      If InRange Then 
       NumOut2 = NumOut2 & arrBuckets(i - 1) 
      End If 
      InRange = False 
     End If 
    Next 

End Function