Option Explicit
Option Private Module
'====================================================================================================
Const UnMax& = 30
'====================================================================================================
Sub GetRangeSimple()
Dim rng As Range
Dim arr, arrA(), adr$, t!, tt!, r&
Dim a2&, arr2() As String, rng2 As Range
tt = Timer
t = Timer
Set rng = Cells(2, 1).Resize(100000, 1)
Range("_rng").Interior.ColorIndex = xlNone
arr = rng.Value
ReDim arr2(UBound(arr, 1) - 1): a2 = -1
Debug.Print "Prepare:", Format$(1000 * (Timer - t), "0 ms")
t = Timer
For r = 1 To UBound(arr, 1)
If arr(r, 1) = 2 Then
a2 = a2 + 1
arr2(a2) = rng(r).Address(0, 0, xlA1)
End If
Next r
If a2 <> UBound(arr2) Then ReDim Preserve arr2(a2)
Debug.Print "Get Address:", Format$(1000 * (Timer - t), "0 ms")
' выбрать ===============
' #1
't = Timer
'Set rng2 = AddressToRange_Old(ActiveSheet, Join(arr2, ","))
'Debug.Print "AdrToRng_OLD:", Format$(1000 * (Timer - t), "0 ms")
' #2
t = Timer
Set rng2 = AddressToRange(ActiveSheet, Join(arr2, ","))
Debug.Print "AdrToRng:", Format$(1000 * (Timer - t), "0 ms")
' КОНЕЦ выбора ==========
t = Timer
rng2.Interior.Color = vbYellow
Debug.Print "Paint:", Format$(1000 * (Timer - t), "0 ms")
Debug.Print "Total time:", Format$(1000 * (Timer - tt), "0 ms")
End Sub
'====================================================================================================
' Time in ms
' Size (range): 10k 20k 30k 40k NEW 40k NEW 100k
' Prepare: 0 20 16 31 31 31
' Get Address: 0 12 16 16 16 47
' Get Range: 375 3 188 10 953 33 195 328 1 844
' Paint: 0 20 16 16 16 47
'
' Total time: 375 3 238 11 000 25 258 391 1 969
'====================================================================================================
'====================================================================================================
Function AddressToRange(sh As Worksheet, ByVal txAdr$) As Range
Dim arrRanges() As Range
Dim r&, i&
If InStr(txAdr, "$") Then txAdr = Replace$(txAdr, "$", "")
i = Len(txAdr)
If i < 256 Then Set AddressToRange = sh.Range(txAdr): Exit Function
r = -1: ReDim arrRanges(Fix(i / 200)) ' создаём массив для хранения с запасом
Do
i = InStrRev(Left$(txAdr, 255), ",") ' ищем запятую с конца первых 255 символов взятой строки
r = r + 1
Set arrRanges(r) = sh.Range(Left$(txAdr, i - 1)) ' заполняем массив диапазонов
txAdr = Mid$(txAdr, i + 1) ' отрезаем от адресной строки использованный фрагмент (взятая строка)
If Len(txAdr) < 256 Then ' если остаток строки можно сразу преобразовать в диапазон …
r = r + 1
Set arrRanges(r) = sh.Range(txAdr) ' … заполняем массив и заканчиваем со строками
ReDim Preserve arrRanges(r)
Set AddressToRange = ArrayUnion(arrRanges): Exit Function
End If
Loop
End Function
'----------------------------------------------------------------------------------------------------
' эффективно (по 30 штук) объединяет все диапазоны массива
Function ArrayUnion(arrRng() As Range) As Range
Dim i&, j&, n&
Do
j = -1
For i = 0 To UBound(arrRng) Step UnMax
j = j + 1
Set arrRng(j) = SmartUnion(arrRng, i)
Next i
'Debug.Print r, arrRanges(r).Address(0, 0, xlA1)
ReDim Preserve arrRng(j)
If j < UnMax Then Set ArrayUnion = SmartUnion(arrRng): Exit Function
Loop
End Function
'----------------------------------------------------------------------------------------------------
' умное объединение диапазонов из переданного массива с помощью Union
Function SmartUnion(arrRng() As Range, Optional iStart&) As Range
Dim s&, n&
s = iStart
n = UBound(arrRng) - s + 1 ' количество элементов от стартового и до конца массива
If n > UnMax Then n = UnMax
If n = UnMax Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24), arrRng(s + 25), arrRng(s + 26), arrRng(s + 27), arrRng(s + 28), arrRng(s + 29)): Exit Function
If n < 11 Then
If n = 1 Then Set SmartUnion = arrRng(s): Exit Function
If n = 2 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1)): Exit Function
If n = 3 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2)): Exit Function
If n = 4 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3)): Exit Function
If n = 5 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4)): Exit Function
If n = 6 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5)): Exit Function
If n = 7 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6)): Exit Function
If n = 8 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7)): Exit Function
If n = 9 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8)): Exit Function
If n = 10 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9)): Exit Function
ElseIf n < 21 Then
If n = 11 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10)): Exit Function
If n = 12 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11)): Exit Function
If n = 13 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12)): Exit Function
If n = 14 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13)): Exit Function
If n = 15 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14)): Exit Function
If n = 16 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15)): Exit Function
If n = 17 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16)): Exit Function
If n = 18 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17)): Exit Function
If n = 19 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18)): Exit Function
If n = 20 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19)): Exit Function
Else
If n = 21 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20)): Exit Function
If n = 22 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21)): Exit Function
If n = 23 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22)): Exit Function
If n = 24 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23)): Exit Function
If n = 25 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24)): Exit Function
If n = 26 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24), arrRng(s + 25)): Exit Function
If n = 27 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24), arrRng(s + 25), arrRng(s + 26)): Exit Function
If n = 28 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24), arrRng(s + 25), arrRng(s + 26), arrRng(s + 27)): Exit Function
If n = 29 Then Set SmartUnion = Union(arrRng(s), arrRng(s + 1), arrRng(s + 2), arrRng(s + 3), arrRng(s + 4), arrRng(s + 5), arrRng(s + 6), arrRng(s + 7), arrRng(s + 8), arrRng(s + 9), arrRng(s + 10), arrRng(s + 11), arrRng(s + 12), arrRng(s + 13), arrRng(s + 14), arrRng(s + 15), arrRng(s + 16), arrRng(s + 17), arrRng(s + 18), arrRng(s + 19), arrRng(s + 20), arrRng(s + 21), arrRng(s + 22), arrRng(s + 23), arrRng(s + 24), arrRng(s + 25), arrRng(s + 26), arrRng(s + 27), arrRng(s + 28)): Exit Function
End If
MsgBox "UNcorrect ranges!", vbCritical, "SmartUnion"
Err.Raise xlErrNA
End Function
'====================================================================================================
'====================================================================================================
'====================================================================================================
Function AdrBlocksToRange_Old(sh As Worksheet, arrAdr() As String) As Range
Dim i&
Set AdrBlocksToRange_Old = sh.Range(arrAdr(0))
If UBound(arrAdr) = 0 Then Exit Function
For i = 1 To UBound(arrAdr)
Set AdrBlocksToRange_Old = Union(AdrBlocksToRange_Old, sh.Range(arrAdr(i)))
Next i
End Function
'----------------------------------------------------------------------------------------------------
Function AddressToRange_Old(sh As Worksheet, ByVal txAdr$) As Range
Dim gr As Range, p&
If Len(txAdr) < 200 Then Set AddressToRange_Old = sh.Range(txAdr): Exit Function
p = InStrRev(Left$(txAdr, 255), ",")
Set gr = sh.Range(Left$(txAdr, p - 1))
txAdr = Mid$(txAdr, p + 1)
While Len(txAdr) > 255
p = InStrRev(Left$(txAdr, 255), ",")
Set gr = Union(gr, sh.Range(Left$(txAdr, p - 1)))
txAdr = Mid$(txAdr, p + 1)
Wend
Set AddressToRange_Old = Union(gr, sh.Range(txAdr))
End Function
'==================================================================================================== |