Option Explicit
'===========================================================================================
Const delimNum$ = "|" ' разделитель ЧИСЕЛ
Const delimRange$ = ":" ' разделитель ДИАПАЗОНА ЧИСЕЛ
'===========================================================================================
Function FILE_List_FromRange(tmpRange, Optional IfColumns As Boolean, Optional IfBoth As Boolean, Optional ByVal MsgIfFalse As Boolean) As Boolean
Dim ar As Range, arrAdr() As String, arrOut()
Dim x, adr$, n&
If TypeName(tmpRange) <> "Range" Then
If MsgIfFalse Then MsgBox "Тип переменной должен быть «Range», а не «" & TypeName(tmpRange) & "»!", vbCritical, "FILE_List_FromRange"
Exit Function
End If
adr = tmpRange.Address(ReferenceStyle:=xlR1C1)
If Len(adr) > 200 Then ' если длина адреса диапазона больше двухсот (навскидку), то он может быть неполным. Собираем по областям…
ReDim arrAdr(tmpRange.Areas.Count - 1)
For Each ar In tmpRange.Areas
arrAdr(n) = ar.Address(ReferenceStyle:=xlR1C1): n = n + 1
Next ar
adr = Join(arrAdr, ","): Erase arrAdr
End If
If IfBoth Then
ReDim arrOut(1)
x = adr: If Not FILE_List_FromAddressR1C1(x, , MsgIfFalse) Then Exit Function Else arrOut(0) = x
x = adr: If Not FILE_List_FromAddressR1C1(x, True, MsgIfFalse) Then Exit Function Else arrOut(1) = x
tmpRange = arrOut
ElseIf IfColumns Then
x = adr: If Not FILE_List_FromAddressR1C1(x, True, MsgIfFalse) Then Exit Function Else tmpRange = x
Else
x = adr: If Not FILE_List_FromAddressR1C1(x, , MsgIfFalse) Then Exit Function Else tmpRange = x
End If
FILE_List_FromRange = True
End Function
'===========================================================================================
Function FILE_List_FromAddressR1C1(tmpAdrR1C1, Optional IfColumns As Boolean, Optional ByVal MsgIfFalse As Boolean) As Boolean
Dim RE As New RegExp
If TypeName(tmpAdrR1C1) <> "String" Then
If MsgIfFalse Then MsgBox "Тип переменной должен быть «String», а не «" & TypeName(tmpAdrR1C1) & "»!", vbCritical, "FILE_List_FromAddressR1C1"
Exit Function
ElseIf Not tmpAdrR1C1 Like "R#*C#*" Then
If MsgIfFalse Then MsgBox "Переменная должна содержать адрес диапазона в стиле «R1C1»!", vbCritical, "FILE_List_FromAddressR1C1"
Exit Function
End If
RE.Global = True
If IfColumns Then
RE.Pattern = "R\d+"
tmpAdrR1C1 = Replace$(RE.Replace(tmpAdrR1C1, ""), "C", "")
Else
RE.Pattern = "C\d+"
tmpAdrR1C1 = Replace$(RE.Replace(tmpAdrR1C1, ""), "R", "")
End If
tmpAdrR1C1 = Replace$(tmpAdrR1C1, ",", "|")
If FILE_List_FromString(tmpAdrR1C1, , MsgIfFalse) Then FILE_List_FromAddressR1C1 = True
End Function
'===========================================================================================
Function FILE_List_FromString(tmpString, Optional ByVal iStepPositive# = 1, Optional ByVal MsgIfFalse As Boolean) As Boolean
Dim dic As New Dictionary
Dim x, y, arr1x(), arrStr() As String
If TypeName(tmpString) <> "String" Then
If MsgIfFalse Then MsgBox "Тип переменной должен быть «String», а не «" & TypeName(tmpString) & "»!", vbCritical, "FILE_List_FromString"
Exit Function
ElseIf iStepPositive <= 0 Then
If MsgIfFalse Then MsgBox "Шаг «" & iStepPositive & "» не может быть МЕНЬШЕ или РАВЕН НОЛЮ!", vbCritical, "FILE_List_FromString"
Exit Function
End If
If InStr(tmpString, delimNum) = 0 Then
ReDim arrStr(0): arrStr(0) = tmpString
Else
arrStr = Split(tmpString, delimNum)
End If
For Each x In arrStr
If InStr(x, delimRange) Then
If Not ListFromRange(x, iStepPositive, MsgIfFalse) Then Exit Function
For Each y In x
y = dic(y)
Next y
Else
If Not IsNumeric(x) Then
If MsgIfFalse Then MsgBox "Элемент массива «" & x & "» не является ЧИСЛОМ!", vbCritical, "FILE_List_FromString"
Exit Function
End If
x = dic(--x)
End If
Next x
Erase arrStr: x = 0: y = 0
arr1x = dic.Keys: dic.RemoveAll
If UBound(arr1x) > 0 Then FILE_Sort_Array1x arr1x, 0, UBound(arr1x)
tmpString = arr1x: FILE_List_FromString = True
End Function
'-------------------------------------------------------------------------------------------
Private Function ListFromRange(tmpStrRng, ByVal iStepPositive#, ByVal MsgIfFalse As Boolean) As Boolean
Dim arrStr() As String, s#, iMin#, iMax#, nStep&
arrStr = Split(tmpStrRng, delimRange)
If UBound(arrStr) > 1 Then
If MsgIfFalse Then MsgBox "Разделителей диапазона «" & delimRange & "» присутствует БОЛЕЕ ОДНОГО!", vbCritical, "ListFromRange"
Exit Function
ElseIf Not IsNumeric(arrStr(0)) Then
If MsgIfFalse Then MsgBox "1ый элемент диапазона «" & arrStr(0) & "» не является ЧИСЛОМ!", vbCritical, "ListFromRange"
Exit Function
ElseIf Not IsNumeric(arrStr(1)) Then
If MsgIfFalse Then MsgBox "2ой элемент диапазона «" & arrStr(1) & "» не является ЧИСЛОМ!", vbCritical, "ListFromRange"
Exit Function
Else
iMin = --arrStr(0)
iMax = --arrStr(1)
If iMin = iMax Then
ReDim tmpStrRng(0): tmpStrRng(0) = iMin
ListFromRange = True: Exit Function
End If
If iMin > iMax Then
s = iMin
iMin = iMax
iMax = s
End If
On Error Resume Next
s = Abs(iMax - iMin) / iStepPositive
If Err Then
If MsgIfFalse Then MsgBox "Шаг «" & iStepPositive & "» НЕ КОРРЕКТЕН!", vbCritical, "ListFromRange"
Exit Function
End If
On Error GoTo 0
If s < 1 Then
If MsgIfFalse Then MsgBox "Шаг «" & iStepPositive & "» не может быть БОЛЬШЕ РАЗНИЦЫ ЧЛЕНОВ:" & vbLf & "«" & iMax & "» – «" & iMin & "» = «" & iMax - iMin & "»!", vbCritical, "ListFromRange"
Exit Function
End If
nStep = Fix(s)
If nStep <> s Then nStep = nStep + 1
ReDim tmpStrRng(nStep)
tmpStrRng(0) = iMin
tmpStrRng(UBound(tmpStrRng)) = iMax
If nStep > 1 Then ' если количество шагов равно одному, то массив уже полностью сформирован, в противном случае дозаполняем массив (кроме первого и последнего члена)
For nStep = 1 To nStep - 1
tmpStrRng(nStep) = --Format$(tmpStrRng(nStep - 1) + iStepPositive, "0.0000000000")
Next nStep
End If
ListFromRange = True
End If
End Function
'===========================================================================================
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Рекурсивный сортер 1x-массива в редакции от Anchoret: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=5&TID=114744&TITLE_SEO=114744-poluchenie-spiska-unikalnykh-znacheniy-iz-odnomernogo-massiva-vba&MID=953013&tags=%D0%9F%D0%BE%D0%BB%D1%83%D1%87%D0%B8%D1%82%D1%8C.%D0%B4%D0%B0%D0%BD%D0%BD%D1%8B%D0%B5.%D1%81%D0%B2%D0%BE%D0%B4%D0%BD%D0%BE%D0%B9+%D1%82%D0%B0%D0%B1%D0%BB%D0%B8%D1%86%D1%8B&_r=9788#message953013
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub FILE_Sort_Array1x(arr1x(), l&, u&)
Dim i&, j&, x, y
i = l: j = u: x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If l < j Then FILE_Sort_Array1x arr1x, l, j
If i < u Then FILE_Sort_Array1x arr1x, i, u
End Sub
'=========================================================================================== |