متراکم کردن مقادیر متوالی به یک ردیف

Question

Rusty فهرستی از کدهای پستی را در ستونی از یک کاربرگ دارد. او می خواهد راهی برای "فشرده کردن" کدها به گونه ای که محدوده های متوالی مقادیر در یک ردیف قرار گیرند. بنابراین، به عنوان مثال، به جای اینکه 35013، 35014، و 35015 سه ردیف را بگیرند، در یک ردیف به عنوان 35013-35015 ظاهر می شوند.

چند راه برای انجام این کار وجود دارد - با یا بدون ماکرو. در سمت "بدون ماکرو" حصار، تعدادی رویکرد مختلف وجود دارد، و همه آنها شامل استفاده از ستون های اضافی برای نگه داشتن نتایج میانی است.

به عنوان مثال، فرض کنید که داده های خود را در ستون A دارید که از سلول A2 شروع می شود و سلول A1 خالی است (حتی متن سرصفحه در آن وجود ندارد). در این حالت می توانید فرمول زیر را در سلول B2 وارد کنید:

=IF(NOT(A2-A1=1),A2,IF(A3-A2=1,B1,A2)) 

سپس در سلول C2 فرمول طولانی زیر را وارد کنید:

=IF(NOT(A3-A2=1),IF(A2-A1=1,TEXT(B1,"00000")
&" - "&TEXT(B2,"00000"),TEXT(A2,"00000")),"")

اکنون می توانید فرمول های سلول های B2:C2 را در ستون های مربوطه کپی کنید. آنچه در ستون C به دست می آورید، سری فشرده کدهای پستی است. می توانید این مقادیر را - با استفاده از Paste Special برای نادیده گرفتن سلول های خالی - در هر جای دیگری که می خواهید کپی کنید.

اگر می خواهید از یک رویکرد کلان استفاده کنید، ستون های میانی لازم نیست. می توان یک ماکرو نوشت که اساساً لیست کدهای پستی را در جای خود جمع می کند. ماکرو زیر در هر محدوده سلولی که انتخاب کرده اید حلقه می زند و لیست فشرده ایجاد می کند:

Sub CombineValues()
    Dim rng As Range
    Dim rCell As Range
    Dim sNewArray() As String
    Dim x As Long
    Dim y As Long
    Dim sStart As String
    Dim sEnd As String

    Set rng = Selection
    sStart = rng.Cells(1)
    sEnd = sStart
    y = 1
    For x = 1 To rng.Count - 1
        If rng.Cells(x + 1) - _
          rng.Cells(x) > 1 Then  End
            ReDim Preserve sNewArray(1 To y)
            If sStart = sEnd Then
                sNewArray(y) = sStart
            Else
                sNewArray(y) = sStart & "-" & sEnd
            End If
            sStart = rng.Cells(x + 1)
            y = y + 1
        End If
        sEnd = rng.Cells(x + 1)
        ReDim Preserve sNewArray(1 To y)
        If sStart = sEnd Then
            sNewArray(y) = sStart
        Else
            sNewArray(y) = sStart & "-" & sEnd
         End If
    Next
    rng.ClearContents
    For x = 1 To y
        rng.Cells(x) = "" & sNewArray(x)
    Next
    Set rng = Nothing
    Set rCell = Nothing
End Sub