Добрый день.
Помогите, пожалуйста, усовершенствовать макрос сокращения строки последовательных чисел путём объединения значений в числовой период с использованием крайних чисел периода и дефиса
На текущий момент макрос распознает следующую строку с определением префикса "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
|
