У Расти есть список почтовых индексов в столбце рабочего листа. Ему нужен способ «сжать» коды так, чтобы последовательные диапазоны значений находились в одной строке. Так, например, вместо 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 вы получите сокращенную серию почтовых индексов. Вы можете скопировать эти значения — используя Специальную вставку для игнорирования пустых ячеек — в любое другое место.

Если вы хотите использовать макро-подход, то промежуточные столбцы не нужны. Можно написать макрос, который сворачивает список почтовых индексов на месте. Следующий макрос просматривает любой выбранный диапазон ячеек и создает сокращенный список:

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

_Примечание: _

Если вы хотите узнать, как использовать макросы, описанные на этой странице (или на любой другой странице на сайтах ExcelTips), я подготовил специальную страницу, содержащую полезную информацию.

link: / excelribbon-ExcelTipsMacros [Щелкните здесь, чтобы открыть эту специальную страницу в новой вкладке браузера].

ExcelTips — ваш источник экономичного обучения Microsoft Excel.

Этот совет (11977) применим к Microsoft Excel 2007, 2010, 2013 и 2016.

Вы можете найти версию этого совета для старого интерфейса меню Excel здесь:

link: / excel-Condensing_Sequential_Values_to_a_Single_Row [Конденсация последовательных значений в одну строку].