Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Объединение последовательных чисел в числовой период
 
Спасибо.
Изменено: mensa - 27 Мар 2019 15:06:09
Сцепить по нескольким критериям
 
Спасибо.
Изменено: mensa - 28 Мар 2019 20:06:47
Объединение последовательных чисел в числовой период
 
Добрый день.
Помогите, пожалуйста, усовершенствовать макрос сокращения строки последовательных чисел путём объединения значений в числовой период с использованием крайних чисел периода и дефиса
На текущий момент макрос распознает следующую строку с определением префикса "QF":
QF1, QF2, QF3, QF5, QF6, QF7, QF8, QF13, QF14, QF15, QF16, QF17, QF18, QF19, QF21, QF33, QF34
и преобразует её в следующую строку с составлением периодов
QF1-QF3, QF5-QF8, QF13-QF19, QF21, QF33, QF34
Интересует добавление условия распознавания  двух периодов и соединения их в один по двум крайним одинаковых значениям, например:
QF1, QF2, QF3, QF5-QF12, QF13-QF19, QF21
преобразовать в:
QF1-QF3, QF5-QF19, QF21
Буду признателен за помощь.
Код
Function comprsStr(sourceElements As String, Optional prefix As String, Optional separatorCells As String, Optional separatorRngs As String) As String
'Const defaultCellsSep  As String = ", "
Dim defaultCellsSep  As String: defaultCellsSep = ", "
'Const defaultRngsSep As String = "-"
Dim defaultRngsSep  As String: defaultRngsSep = "-"
Dim aElements As Variant
Dim aValues As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
    comprsStr = "?" ' Результат для ошибочного набора параметров или какой-то ошибки по ходу вычислений
    If IsMissing(separatorCells) Then
        separatorCells = defaultCellsSep
    End If
    If IsMissing(separatorRngs) Then
        separatorRngs = defaultRngsSep
    End If
    aElements = Split(sourceElements, separatorCells)
    If LBound(aElements) = UBound(aElements) Then ' Всего один элемент? Или не правильный сепаратор...
        comprsStr = Trim(sourceElements)
        Exit Function
    End If
    If IsMissing(prefix) Then
        prefix = ""
        For i = 1 To Len(aElements(0))
            If InStr("0123456789", Mid(aElements(0), i, 1)) > 0 Then Exit For
            prefix = prefix + Mid(aElements(0), i, 1)
        Next i
    End If
    ReDim aValues(UBound(aElements))
'    aValues = DimArray(UBound(aElements))
    For i = LBound(aElements) To UBound(aElements)
        aValues(i) = Val(Join(Split(aElements(i), prefix), ""))
    Next i
    Dim aSeries() As Long
    ReDim aSeries(UBound(aElements))
'Dim aSeries(UBound(aElements)) As Long
    n = 1
    aSeries(0) = n
    For i = LBound(aElements) + 1 To UBound(aElements)
        If aValues(i) - aValues(i - 1) <> 1 Then n = n + 1 ' Не просто "больше", а "не равно" - порядок сортировки мы не проверяли
        aSeries(i) = n
    Next i
    If n >= (UBound(aElements) / 2) Then ' Нет ни одной серии больше двух элементов подряд
        comprsStr = Trim(sourceElements)
        Exit Function
    End If
    Dim aCounts() As Long
    ReDim aCounts(n)
'Dim aCounts(n) As Long

    For i = LBound(aElements) To UBound(aElements)
        aCounts(aSeries(i)) = aCounts(aSeries(i)) + 1
    Next i
Rem Собираем данные для результата
Dim aRes() As String
ReDim aRes(UBound(aElements))
'Dim aRes(UBound(aElements)) As String
    i = 0
    j = 0
    For k = 1 To n
        If aCounts(k) = 1 Then
            aRes(j) = aElements(i)
            i = i + 1
            j = j + 1
        ElseIf aCounts(k) = 2 Then
Страницы: 1
Наверх