Вопрос не новый, но хотелось бы прояснить: обычно, чтобы получить массив из значений только видимых ячеек выделенного диапазона, Selection.SpecialCells(xlVisible) копируют и вставляют на временный лист и потом с этого листа забирают данные в массив обычным способом
Можно ли как-то ускорить этот процесс? Я подумал вот о чём: мы же когда копируем видимые ячейки в буфер, то там уже все эти данные есть. Совершенно незачем создавать лист, вставлять данные на него, забирать их в массив и удалять лист. Вот только как эти данные достать из буфера?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Совершенно незачем создавать лист, вставлять данные на него, забирать их в массив и удалять лист
Совершенно незачем Хм, поторопился. Так, как в коде ниже, в массив попадает только первая область видимых ячеек всего диапазона. Думаю без цикла по видимым ячейкам (областям?) не обойтись
да я уже успел всякое попробовать Цикл, например, плох тем, что зависит от порядка выделения областей, а хочется получить данные "как вижу", несмотря на последовательность выделения. Можно обойти заставляя выделять одну область и определяя видимые внутри кода, но тогда, соответственно, лишаемся возможности "забирать" несмежные диапазоны…
плюс там ещё свои заморочки с определением размеров массива — видимые области могут состоять и из одной ячейки и из одного столбца и из одной строки. Непросто в таком случае построить корректный массив точь-в-точь. Как раз таки всё это очень хорошо обходит копипаст на служебный лист
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sub aaaa()
Dim aa As Range, bb As Range, DCr As Object, DCc As Object, arr(), a&, b&, qq(), ww()
Set DCr = CreateObject("Scripting.Dictionary")
Set DCc = CreateObject("Scripting.Dictionary")
For Each aa In Selection.Areas
For Each bb In aa.Cells
DCr.Item(bb.Row) = DCr.Item(bb.Row) + 1
DCc.Item(bb.Column) = DCc.Item(bb.Column) + 1
Next
Next
ReDim arr(1 To DCr.Count, 1 To DCc.Count)
qq = DCr.keys(): arrSort qq()
ww = DCc.keys(): arrSort ww()
For a = 1 To UBound(arr)
For b = 1 To UBound(arr, 2)
arr(a, b) = Cells(qq(a - 1), ww(b - 1)).Value
Next
Next
End Sub
Private Sub arrSort(arr())
Dim a&, b&, aa()
aa = arr
For a = LBound(arr) + 1 To UBound(arr)
b = a
Do While aa(b - 1) > arr(a)
aa(b) = aa(b - 1): b = b - 1
If b = LBound(arr) Then Exit Do
Loop
aa(b) = arr(a)
Next
arr = aa
End Sub
Anchoret, вау. Собрать строки и столбцы в словари, отсортировать ключи и наполнить массив поячеечно может быть быстрее на малых и средних данных. Тем более, думаю, что можно ещё ускорить. Как минимум спецсортером для целых положительных чисел… Спасибо!
По буферу есть у еого идеи?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Итак, тесты: • Поле:Range("_data"): 20 столбцов * 5 000 строк = 100k ячеек • Скрыто: строки, где в 1 столбце есть "*5*" (1 355 строк из 5 000) и чётные столбцы, кроме последнего (9 столбцов из 20) • Видно: 40 095 ячеек из 100 000 в 920 областях • Время получение массива: 0,3-0,4 секунды
На основе вашей идеи создал немного другую функцию и скорость мне очень нравится
Код
Option Explicit
Option Private Module
'===========================================================================================
Private Sub Start()
Dim arr(), t!
shStart.Columns("A:K").ClearContents
t = Timer
arr = Array2x_GetFromVisible([_data].SpecialCells(xlVisible))
t = Timer - t
shStart.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
shStart.Select
MsgBox Format$(t, "0.00")
End Sub
'===========================================================================================
Private Function Array2x_GetFromVisible(ByVal rng As Range) As Variant()
Dim sh As Worksheet, cl As Range, dicR As New Dictionary, dicC As New Dictionary
Dim arr(), arrR(), arrC(), r&, c&
Set rng = rng.SpecialCells(xlVisible)
For Each cl In rng
r = dicR.Item(cl.Row)
c = dicC.Item(cl.Column)
Next cl
Set sh = rng.Parent
ReDim arr(1 To dicR.Count, 1 To dicC.Count)
arrR = dicR.Keys
dicR.RemoveAll
Array1xSort arrR, 0, UBound(arrR)
arrC = dicC.Keys
dicC.RemoveAll
Array1xSort arrC, 0, UBound(arrC)
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
arr(r, c) = sh.Cells(arrR(r - 1), arrC(c - 1)).Value2
Next r
Next c
Array2x_GetFromVisible = arr
End Function
'-------------------------------------------------------------------------------------------
Private Sub Array1xSort(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 Array1xSort arr1x, l, j
If i < u Then Array1xSort arr1x, i, u
End Sub
нужно учитывать, что функция стоит передавать ОДНУ область (встроить проверку), дальше она сама
Также заменил сортер на рекурсию (кстати, ваша версия), т.к. этот очень тугой (на 10 000 - 2 секунды против 0,01 у рекурсии). Хотя я сначала подумал, что этот сортер специально для положительных целых чисел от единицы и будет быстрее…
Тест сортеров
Код
Sub Sorters()
Dim arr(), arrTemp(), i&, t!
Const nMax& = 1000
ReDim arrTemp(nMax - 1): Randomize
t = Timer
For i = 0 To UBound(arrTemp)
arrTemp(i) = Int(nMax * Rnd + 1)
Next i
Debug.Print "Array Create: " & Format$(Timer - t, "0.00")
arr = arrTemp
t = Timer
arrSort arr
Debug.Print "Long Sorter: " & Format$(Timer - t, "0.00")
arr = arrTemp
t = Timer
Array1xSort arr, 0, UBound(arr)
Debug.Print "Recursive Sorter: " & Format$(Timer - t, "0.00")
End Sub
'===========================================================================================
Private Sub arrSort(arr())
Dim a&, b&, aa()
aa = arr
For a = LBound(arr) + 1 To UBound(arr)
b = a
Do While aa(b - 1) > arr(a)
aa(b) = aa(b - 1): b = b - 1
If b = LBound(arr) Then Exit Do
Loop
aa(b) = arr(a)
Next a
arr = aa
End Sub
'-------------------------------------------------------------------------------------------
Private Sub Array1xSort(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 Array1xSort arr1x, l, j
If i < u Then Array1xSort arr1x, i, u
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, в макросе выше используются "вставки" - они не предназначены для больших массивов, максимум до 3к элементов. Для сортировки целых чисел равномерно распределенных в массиве по значению лучше использовать другой сортер, где: - определяются минимум и максимум по значениям - создается массив размером разница между мин/максом поделенная на два. - в этот массив по расчитанному коэф.заносятся эелементы сортируемого массива - далее сборка итогового массива (отсортированного). на всякий пожарный каждый суб.массив перед заносом в итоговый лучше прогнать через "вставки"
П.С.: Вроде в теме про сортировки был такой сортер.
Anchoret: лучше использовать другой сортер…в теме про сортировки был такой сортер
скорость вполне приемлима, а сортер целочисленных действительно был, но я его не тестил. Пока нет такой необходимости. Спасибо
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄