Sıralı numaraları düzenleme

[Usyk]

A1 sütununda aşağıdaki örnekteki gibi dizin sayfa numaraları var. Bunları örnekteki gibi düzenleyebilir miyim?
Seri takip eden numaraları "-" ile sadeleştirmem gerekiyor.
Yardımcı olabilirseniz büyük yükten kurtulurum.
Teşekkürler.

Orjinal:
1, 2, 3, 4, 5, 6, 9, 12, 13, 14, 15, 16, 20
134, 135, 136, 148

Yapmak istediğim:
1-6, 9, 12-16, 20
134-136, 148

 

[hamitcan]

Benim için güzel bir beyin jimnastiği oldu. Eminim daha kısa bir yolu vardır.

Sub Parcaal2()
    Dim x() As String
    a = [a2]
    x = Split(a, ",")
    t = 1
    On Error Resume Next
    Columns(3).Clear
    For i = 0 To UBound(x) + 1
    t = t + 1
    Cells(t, 3) = x(i) * 1
    If Val((x(i + 1) - x(i))) > 1 Then
        a = WorksheetFunction.Min(Columns(3))
        b = WorksheetFunction.Max(Columns(3))
        s = WorksheetFunction.CountA(Columns(3))
        k = IIf(s = 1, a, a & "-" & b)
        sonuc = sonuc & "," & k
        a = ""
        b = ""
        Columns(3).Clear
        t = 1
    End If
    Next
MsgBox Mid(sonuc, 2, Len(sonuc) - 5)
End Sub

 

[Korhan Ayhan]

Bu bahsettiğiniz sıra numaraları "A" sütununda alt alta mı bulunuyor? Yoksa tek bir hücre içinde mi bulunuyor?

Eğer alt alta ise alternatif kod;

Yeni grup listesi "C" sütununda listelenir.

Option Explicit

Sub Numaralari_Gruplandir()
    Dim X As Long, Son As Long, Liste As Variant, Zaman As Double
    Dim Grup_NoX As String, Grup_NoY As String, Say As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Zaman = Timer
   
    Son = Cells(Rows.Count, 1).End(3).Row
    Liste = Range("A1:A" & Son).Value
    ReDim Grup(1 To UBound(Liste), 1 To 1)
   
    For X = 1 To UBound(Liste, 1)
        If X - 1 <> 0 Then
            If Liste(X, 1) - Liste(X - 1, 1) = 1 Then
                If Grup_NoX = "" Then
                    Grup_NoX = Liste(X - 1, 1)
                End If
                Grup_NoY = Liste(X, 1)
            Else
                If Grup_NoX = "" Then
                    Grup_NoX = Liste(X - 1, 1)
                    Grup_NoY = Liste(X - 1, 1)
                End If
               
                Say = Say + 1
                Grup(Say, 1) = Grup_NoX & IIf(Grup_NoX = Grup_NoY, "", " - " & Grup_NoY)
                Grup_NoX = ""
                Grup_NoY = ""
            End If
       
            If X = UBound(Liste, 1) Then
                If Grup_NoX = "" Then
                    Grup_NoX = Liste(X, 1)
                    Grup_NoY = Liste(X, 1)
                End If
               
                Say = Say + 1
                Grup(Say, 1) = Grup_NoX & IIf(Grup_NoX = Grup_NoY, "", " - " & Grup_NoY)
                Grup_NoX = ""
                Grup_NoY = ""
            End If
        End If
    Next

    Range("C:C").ClearContents
    Range("C:C").NumberFormat = "@"
    Range("C1").Resize(Say, 1) = Grup
    Columns(3).AutoFit

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Gruplandırma işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Usyk]

Korhan bey hemen deniyorum.

 

[Usyk]

Korhan bey denedim ancak hata veriyor.

Liste A sütununda ayrı ayrı satırlarda aşağıdaki şekilde yer alıyor. Virgüllerden sonra birer boşluk var.

A1= 134, 135, 136, 148
A2= 278
A3= 74, 76
A4= 83, 86, 223, 246, 362
A5= 182, 183, 185, 262
A6= 150
A7= 3, 9, 26, 27, 40, 55, 68, 69, 70, 123, 153, 154, 156, 157, 158, 159, 160, 161, 234, 235, 281, 282, 283, 323, 385, 386, 388, 389
...

 

[Usyk]

Syn Hamitcan,

Mesaj kutusunda verdirdiğiniz sonucu A sütunundaki değerlerin tamamı için yan sütuna yazdırabilir miyiz?

 

[hamitcan]

Aşağıdaki gibi deneyin.

Sub Parcaal2()
    Dim x() As String
    For j = 2 To [a65536].End(3).Row
    sonuc = ""
    a = Cells(j, 1)
    x = Split(a, ",")
    t = 1
    On Error Resume Next
    Columns(3).Clear
    For i = 0 To UBound(x) + 1
    t = t + 1
    Cells(t, 3) = x(i) * 1
    If Val((x(i + 1) - x(i))) > 1 Then
        a = WorksheetFunction.Min(Columns(3))
        b = WorksheetFunction.Max(Columns(3))
        s = WorksheetFunction.CountA(Columns(3))
        k = IIf(s = 1, a, a & "-" & b)
        sonuc = sonuc & "," & k
        a = ""
        b = ""
        Columns(3).Clear
        t = 1
    End If
    Next
Cells(j, 2) = Mid(sonuc, 2, Len(sonuc) - 5)
Next
End Sub

 

[Usyk]

Sn. Hamitcan,

Genel olarak istediğimi verdi. Bazı satırlarda virgül yerine nokta (.) yazıyor ve virgüllerden sonra boşluk vermiyor.
Onu da ben düzeltirim artık.

İlginiz ve yardımınız için teşekkür ederim.

 

[hamitcan]

Virgülden sonra boşluk koyabilirsiniz.
sonuc = sonuc & ", " & k

 

[Korhan Ayhan]

Alt alta olan listeleri gruplandırmak için önerdiğim kodda küçük bir sorun vardı. Revize ettim.

Sizin listenizdeki durum farklı olduğu için @hamitcan beyin önerisini kullanın.

 

[Usyk]

Hamitcan bey,

O kısmı farketmemişim, boşluğu ekleyince (.) sorunu da düzeldi. Teşekkür ederim.