Доброго времени суток, Планетяне! Сразу оговорюсь, что такое обобщающее название из-за того, что все задачи я хочу решить похожими способами.
До недавнего времени в качестве ВПР использовал UDF на основе Match - работала довольно шустро и вполне себе устраивала. А на неделе столкнулся с проблемой, что Match не работает со строками длиннее 255 символов. А у меня, вследствие "сырости" и несовершенства связей бывают длинные "ключи". Ну а так как массивы быстрые, а в словаре удобно хранить, проверять и извлекать, то решил сочинить новую UDF на основе данных объектов.
Изучая словари (все ссылки ниже), понял, что словарь может показать "уникальность" объекта при добавлении в него или посчитать количество повторов, поэтому, по сути, хочу написать 2 UDF: чисто для ВПР и для определения количества вхождений.
Текущий ВПР на Match
Код
Public Function PRDX_VPR(WF_what, WF_where As Range, WF_get As Range) As Variant
Dim N&
On Error GoTo er
N = Application.WorksheetFunction.Match(WF_what, WF_where, 0)
PRDX_VPR = WF_get(N).Value
If PRDX_VPR = 0 Then GoTo er:
GoTo fin:
er:
PRDX_VPR = ""
fin:
On Error GoTo 0
End Function
UPD from 2018-02-16. Решения по ВПР:1 и 2. До решения от Anchoret пока не дорос((
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Сортировка на словарях - плохая затея Проверено. Слабое место словарей - долгая загрузка в него данных. Строковые ключи можно искать и в массивах методом первичного распределения (распихать по матрице). Только распихивать не значения, а индексы. Разбить по первой букве строки. Если значений мало, то прямой поиск. Если значений много, то делаем выборку индексов по второй букве искомой строки. И т.д.. Для разбивки строки на коды символов можно воспользоваться след.конструкцией:
Код
Dim bb() as byte' массив для кодов символов
Dim st as String
bb=StrConv(st,128)'или VBA константа vbFromUnicode
По поводу UDF (ВПР) уточните, пожалуйста, максимальные размеры массива, т.к. от этого зависит решение. И как Вы используете эту UDF: в формулах (массивных?) ячеек или только в VBA? Сколько примерно ожидается обращений к одному и тому же массиву? Сколько таких массивов предполагается использовать в одной книге? Проще всего приложить пример.
И пока тему не закрыли, небольшой оффтоп по сортировкам: Обычно приходится искать компромисс между скоростью, функциональностью и удобством (простотой) применения. При увлечении одним из этих компонентов страдают остальные. При акценте на скорости кода сам код может выглядеть жутковато (использование GoTo label и т.п.) и/или заточен на узкое применение. При погоне за многофункциональностью (сортировка по возрастанию/убыванию, учёт регистра текста и многое другое) страдает скорость, а чрезмерное количество параметров, процедур и функций начинает отпугивать самых массовых пользователей. Что касается простоты, то чаще востребована сортировка по возрастанию без учета регистра текста. Абстрагирование от Excel (сортировка в VBA сама по себе) тоже редко кому нужна, встроенная сортировка вполне устраивает в большинстве типовых задач, но бывают случаи, когда хочется обойтись только VBA. Еще бы хороший стиль написания (внятные имена переменных хотя бы), подробное комментирование, чтобы не изучать алгоритм по порой чудаковатому коду, и внятное описание, желательно с примерами. Если понимать, для кого предлагается решение, то легче выбрать и правильный компромисс. Примеры точного попадания в целевую группу - Приемы Автора сайта. Акцент на каких-то сложных т.н. вау-эффектах может оказаться воспринят только такими же «чудиками», как и автор креатива, хотя это вполне себе целевая группа, конечно
Добавлю ссылку. По сортировкам с подачи Слэна когда-то в теме «Как в VBA отсортировать массив?» обсуждался нерекурсивный алгоритм сортировки QuickSort, как наиболее быстрый для больших массивов. При этом был немного отшлифован код GSerg (Сергея Гергерта, насколько я понимаю) для одномерного массива, взятый с vbnet.ru В той же теме обсуждалось, что для 2D-массивов лучше (быстрее) вместо перестановок значений делать перестановки их индексов (номеров строк, а точнее - 2-й размерности) в массиве, а в конце – по этим индексам сформировать отсортированный массив. В том или ином виде код и методы используются и модифицируются во многих решениях на этом и других форумах.
Еще немного о сортировках Т.к. до сих пор интересуюсь этой темой, то переворошил инет в поисках информации. Краткая выжимка из прочитанного и опробованного:
Скрытый текст
1. Самые долгие, но при этом простые универсальные алгоритмы в порядке увеличения КПД (исключая экзотику): -- пузырёк в его классическом виде -- вставки классик без использования доп.массивов -- выборка минимального/максимального значения в каждом проходе - сортировка выбором. 2. Середнячок - модифицированные базовые алгоритмы: -- сортировка выбором с определением и минимального и максимального значений за проход -- пузырь в двупроходной реализации с первичным перетряхиванием входного массива (элементы меньшие по значению в начало массива, большие в конец) -- вставки с доп.массивом с грубой предсортировкой, как в предыдущем пункте -- расчёска - модифицированный пузырь 3, Алгоритмы со скоростью работы (сортировки) выше среднего. -- сортировка Шелла - улучшенная сортировка вставками, тут важно расчитать шаг -- расчёска + вставки на доп.массиве - всего в два раза медленнее (можно ускорить) квиксорта -- сортировка слиянием --- модификация сортировки слиянием + квиксорт = TimSort -- поразрядные сортировки (их два базовых вида + модификации) -- алгоритм от AAF, в котором толком не разобрался -- квиксорт -- корзинная или карманная сортировка, в которой используется метод распределения. Но тут есть нюансы и нужен доп.анализ массива на типы данных. В случае текста и в чистом виде такой метод проигрывает квику по скорости.
Есть еще метод двоичного дерева, но насколько я понял этот метод только для чисел, т.е. не универсал по входным данным. Также есть ABCsort от предприимчивого богослова (лицензированный и сертифицированный в США, но так и не попавший в Википедию).
Из лидеров по времени квиксорт, тимсорт и слияние наплевательски относятся к взаимоположению равных элементов, что важно для сортировки двумерного массива.
Из «медленных простых универсальных» ещё можно обратить внимание на т.н. гномью сортировку, главный бонус которой в сравнении с пузырьками — отсутствие вложенного цикла. Сложность та же n^2, но при прочих равных гномы обычно обгоняют пузырьки именно за счёт более оптимального распределения ресурсов.
Господа! Желаю всем здравствовать! Итак - по порядку…
Цитата
Anchoret написал: Сортировка на словарях - плохая затея
я не собирался сортировать словари. Просто предполагаю, что, загрузив диапазон с листа в двумерный массив, перед тем как искать по нему, было бы неплохо отсортировать. Причём, вот тут увидел метод, когда массив загружается 1 раз для всего диапазона работы UDF и это, тип экономит кучу ресурсов (я понял как-то так). Предложенный вами метод преобразования строки в набор символов - это для бинарного поиска? А как его реализовать?)))
Цитата
Ігор Гончаренко написал: в заголовке нет описания задачи, которую нужно решить
она там была - в подзаголовке темы "Суперфункции для ВПР и поиска количества вхождений дубликатов" (что-то типа того). Модераторы подчистили, наверное. Не удалили тему - и слава богу)))
ZVI, по размерам массивов, компромиссам и т.д.: для меня в приоритете надёжность, универсальность и удобство ввода. На данный момент я использую подход, когда в надстройке хранятся так называемые "базовые" модули с макросами и UDF. А уже в UDF листа или макросах для юзеров я использую обращение к этим "базовым" кодам. Например, есть куча функций проверки корректности:
Пример «базового модуля с функциями проверок»
Код
Option Explicit
Public Function PRDX_IsNotEmptyArray(WF_arr As Variant) As Boolean
On Error Resume Next
PRDX_IsNotEmptyArray = LBound(WF_arr) <= UBound(WF_arr)
End Function
'=========================================================================================================================
Public Function PRDX_CheckRng(WF_rng As Range) As Boolean
If (TypeName(WF_rng) = "Range") And Not (WF_rng Is Nothing) And (IsError(WF_rng) = False) And _
(ActiveSheet.ProtectContents = False) Then PRDX_CheckRng = True: Exit Function
PRDX_CheckRng = False
End Function
'=========================================================================================================================
'От Дмитрия Щербакова: http://www.excel-vba.ru/chto-umeet-excel/kak-uznat-sushhestvuet-li-list-v-knige/
'=========================================================================================================================
Public Function PRDX_SheetExist(WF_txt1 As String) As Boolean
Dim WF_sh As Worksheet
On Error Resume Next
Set WF_sh = ActiveWorkbook.Sheets(WF_txt1)
PRDX_SheetExist = Not WF_sh Is Nothing
End Function
'=========================================================================================================================
Public Function PRDX_NameExist(WF_txt1 As String) As Boolean
PRDX_NameExist = TypeOf Evaluate(WF_txt1) Is Range
End Function
'=========================================================================================================================
Public Function PRDX_LastCell(Optional WF_IfCol As Boolean = False, Optional WF_ByCell As Boolean = False, Optional WF_Row As Long = 1, Optional WF_Column As Integer = 1) As Long
Dim WF_r&, WF_c%
On Error GoTo er
WF_r = 0: WF_c = 0
If WF_ByCell = True Then
WF_r = Cells(Rows.Count, WF_Column).End(xlUp).Row
WF_c = Cells(WF_Row, Columns.Count).End(xlToLeft).Column
GoTo cont:
End If
With ActiveSheet.UsedRange: End With
WF_r = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
WF_c = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
cont:
If WF_r = 0 Or WF_c = 0 Then GoTo er:
If WF_IfCol = True Then PRDX_LastCell = WF_c: GoTo fin
PRDX_LastCell = WF_r
GoTo fin:
er:
PRDX_LastCell = 0
fin:
On Error GoTo 0
End Function
'Пример заворачивания "базовых функций" в UDF для использования на листе
Public Function ПроверкаПустот(Диапазон As Range) As String
On Error GoTo er
If PRDX_HaveEmpty(Диапазон) = False Then ПроверкаПустот = "ГОТОВО": GoTo fin:
er:
ПроверкаПустот = ""
fin:
End Function
Anchoret и Irregular Expression, о сортировках: в рамках моей задачи может и не нужно будет применять сортировки. Гляньте первые примеры кодов, пожалуйста
Вообще, ребят, многие очень крутые вещи, которые вы мне тут предлагаете для меня является тёмным лесом, т.к. по сути, я ещё нуб в VBA и, порой порю редкую чушь из-за того, что просто не знаю основ и "матчасти". Прошу простить и по-возможности просветить и помочь)) Обновил шапку
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
'====================================================================================================================
Public Function Подтянуть3(ByVal Что_ищем, ByRef Где_ищем As Range, ByRef Откуда_тянем As Range)
Dim arrWhere, arrGet
Dim del$
On Error GoTo er
del = "•"
arrWhere = Split(xlVBA_Range2TXT2(Где_ищем, del, del, del), del)
arrGet = Split(xlVBA_Range2TXT2(Откуда_тянем, del, del, del), del)
Подтянуть3 = PRDX_VPR_Array3(Что_ищем, arrWhere, arrGet)
GoTo fin
er:
Подтянуть3 = ""
fin:
End Function
'====================================================================================================================
Public Function PRDX_VPR_Array3(ByVal WF_what, WF_where, WF_get)
Dim i&
On Error GoTo er
' If (UBound(WF_where()) - LBound(WF_where())) <> (UBound(WF_get()) - LBound(WF_get())) Then GoTo er
For i = LBound(WF_where) To UBound(WF_where)
If WF_where(i) = WF_what Then PRDX_VPR_Array3 = WF_get(i): GoTo fin
Next i
'GoTo er
'ex:
' If LBound(WF_where()) = LBound(WF_get()) Then PRDX_VPR_Array3 = WF_get(i)
' If LBound(WF_where()) = LBound(WF_get()) + 1 Then PRDX_VPR_Array3 = WF_get(i - 1)
' If LBound(WF_where()) = LBound(WF_get()) - 1 Then PRDX_VPR_Array3 = WF_get(i + 1)
'GoTo fin
er:
PRDX_VPR_Array3 = ""
fin:
On Error GoTo 0
End Function
'====================================================================================================================
Public Function xlVBA_Range2TXT2(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = "•", Optional ByVal RowsSeparator$ = "•", Optional ByVal AreasSeparator$ = "•") As String
Dim ar As Range
Dim arr
Dim i&, j&
Dim txt$
If ra.Cells.Count = 1 Then xlVBA_Range2TXT2 = ra.Value2: Exit Function
If ra.Areas.Count > 1 Then
For Each ar In ra.Areas
xlVBA_Range2TXT2 = xlVBA_Range2TXT2 & AreasSeparator$ & xlVBA_Range2TXT2(ar, ColumnsSeparator$, RowsSeparator$)
Next ar
xlVBA_Range2TXT2 = Mid(xlVBA_Range2TXT2, Len(AreasSeparator) + 1)
Exit Function
End If
arr = ra.Value
For i = LBound(arr, 1) To UBound(arr, 1)
txt = "": For j = LBound(arr, 2) To UBound(arr, 2): txt = txt & ColumnsSeparator$ & arr(i, j): Next j
xlVBA_Range2TXT2 = xlVBA_Range2TXT2 & Mid(txt, Len(ColumnsSeparator$) + 1) & RowsSeparator$
Next i
xlVBA_Range2TXT2 = Left(xlVBA_Range2TXT2, Len(xlVBA_Range2TXT2) - 1)
End Function
Изменённый вариант работает корректно
Код
Option Explicit
'====================================================================================================================
Public Function Подтянуть3(ByVal Что_ищем, ByRef Где_ищем As Range, ByRef Откуда_тянем As Range)
Dim arrWhere, arrGet
On Error GoTo er
arrWhere = Где_ищем.Value2
arrGet = Откуда_тянем.Value2
Подтянуть3 = PRDX_VPR_Array3(Что_ищем, arrWhere, arrGet)
GoTo fin
er:
Подтянуть3 = ""
fin:
End Function
'====================================================================================================================
Public Function PRDX_VPR_Array2(ByVal WF_what, WF_where, WF_get)
Dim i&
On Error GoTo er
For i = LBound(WF_where, 1) To UBound(WF_where, 1)
If WF_where(i, 1) = WF_what Then PRDX_VPR_Array2 = WF_get(i, 1): GoTo fin
Next i
er:
PRDX_VPR_Array2 = ""
fin:
On Error GoTo 0
End Function
работает хоть и корректно, но в несколько раз дольше, чем Match (вероятно, из-за длинных ключей)
Тупой перебор ячеек
Код
Public Function Подтянуть4(ByVal Что_ищем, ByRef Где_ищем As Range, ByRef Откуда_тянем As Range)
Dim cl As Range
On Error GoTo er
For Each cl In Где_ищем
If cl = Что_ищем Then Подтянуть4 = Откуда_тянем(cl.Row).Value2: GoTo fin
Next cl
er:
Подтянуть4 = ""
fin:
End Function
Перебор "в лоб" работает примерно также по скорости, как и предущий (Подтянуть3). Оба они решают проблему с длинными ключами, но хочется чего-то более быстрого и продвинутого))) пробую дальше)))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
В общем, по ВПР пока варианта 2: 1. делать проверку на длину строки и, в зависимости от этого использовать либо Match, либо "тупой перебор ячеек" 2. использовать метод от Anchoret, но я не знаю как разобрался как работает функция, получил из строки массив типа Byte с кодами символов, но как их дальше сравнивать не понимаю…
Помогите, кто может, пожалуйста или подскажите другой вариант.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Предложенный вами метод преобразования строки в набор символов - это для бинарного поиска? А как его реализовать?)))
Не совсем. Для бинарного поиска нужен отсортированный массив. Вот примерный набросок, но результат по времени далек от идеала:
Скрытый текст
Код
Sub Test() 'микро тестовый стенд для оценки скорости
Dim sLen$(), a&, b%, n%, qwerty(), txt$(), aa, fc&
uu1 = Timer
ReDim qwerty(1 To 500000, 1 To 1): ReDim txt(1 To 10000)
sLen = Split("3/3", "/")
For a = 1 To UBound(qwerty, 1)
For b = 1 To UBound(qwerty, 2)
TextGen qwerty(a, b), CInt(sLen(0)), CInt(sLen(1))
Next
Next
uu1 = Timer - uu1
Debug.Print "Main Arr.: " & UBound(qwerty, 1) & "x" & UBound(qwerty, 2)
Debug.Print "Search Arr.: " & UBound(txt)
Debug.Print "Generation 1: " & uu1
uu2 = Timer
For a = 1 To UBound(txt)
TextGen aa, CInt(sLen(0)), CInt(sLen(1))
txt(a) = aa
Next
uu2 = Timer - uu2
Debug.Print "Generation 2: " & uu2
uu = Timer
TxtFinder txt(), qwerty(), 1, aa, fc
uu = Timer - uu
Debug.Print "Search Time: " & uu
Debug.Print "Founded, counts: " & fc
End Sub
'----------------- функция RND по стрингам --------------
Function TextGen(tt, ByVal ss%, ByVal ll%)
Dim aa As Byte, x%, t$, arr() As Byte, a As Byte, c%
ReDim arr(1 To 4, 1 To 2)
arr(1, 1) = 65: arr(1, 2) = 25: arr(2, 1) = 97: arr(2, 2) = 25
arr(3, 1) = 192: arr(3, 2) = 31: arr(4, 1) = 224: arr(4, 2) = 31
t = ""
If ll - ss > 0 Then c = ss + (Rnd * (ll - ss)) Else c = ll
For x = 1 To c
a = Rnd * 4
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
t = t & Chr(aa)
Next
tt = t
End Function
'------------------- ну и сам поисковик -----------------
Sub TxtFinder(txt$(), mass(), ByVal n%, arr, fc&)
Dim ll&, hh&, dt$, cc As Byte, a&, i%, x&, gg&(), mtrx(), mtrx1()
ll = LBound(mass, 1): hh = UBound(mass, 1)
ReDim arr(LBound(txt) To UBound(txt), 1 To 2) 'кол-во найденных элементов, одномерный массив индексов
ReDim mtrx(0 To 255, 1 To 2)
For a = LBound(txt) To UBound(txt)
cc = Asc(txt(a)): mtrx(cc, 1) = mtrx(cc, 1) + 1
Next
For a = LBound(txt) To UBound(txt) 'индексируем (разбиваем по 1-му символу поисковые строки)
cc = Asc(txt(a))
If Not IsArray(mtrx(cc, 2)) Then
ReDim gg(1 To mtrx(cc, 1))
gg(1) = a: mtrx(cc, 1) = 1: mtrx(cc, 2) = gg()
Else
mtrx(cc, 1) = mtrx(cc, 1) + 1: mtrx(cc, 2)(mtrx(cc, 1)) = a
End If
Next
ReDim mtrx1(0 To 255, 1 To 2)
For a = ll To hh 'индексация (разбиваем по 1-му символу строки опорного столбца входного массива )
cc = Asc(mass(a, n)): mtrx1(cc, 1) = mtrx1(cc, 1) + 1
Next
For a = ll To hh
cc = Asc(mass(a, n))
If Not IsArray(mtrx1(cc, 2)) Then
ReDim gg(1 To mtrx1(cc, 1))
gg(1) = a: mtrx1(cc, 1) = 1: mtrx1(cc, 2) = gg()
Else
mtrx1(cc, 1) = mtrx1(cc, 1) + 1: mtrx1(cc, 2)(mtrx1(cc, 1)) = a
End If
Next
For i = 0 To 255 '
If mtrx(i, 1) > 0 Then
If mtrx1(i, 1) > 0 Then
For a = 1 To mtrx(i, 1)
dt = txt(mtrx(i, 2)(a))
For x = 1 To mtrx1(i, 1)
If dt = mass(mtrx1(i, 2)(x), n) Then
arr(mtrx(i, 2)(a), 1) = arr(mtrx(i, 2)(a), 1) + 1
If Not IsArray(arr(mtrx(i, 2)(a), 2)) Then
ReDim gg(1 To 1): gg(1) = mtrx1(i, 2)(x)
arr(mtrx(i, 2)(a), 2) = gg(): fc = fc + 1
Else
gg = arr(mtrx(i, 2)(a), 2)
ReDim Preserve gg(1 To arr(mtrx(i, 2)(a), 1))
gg(arr(mtrx(i, 2)(a), 1)) = mtrx1(i, 2)(x)
arr(mtrx(i, 2)(a), 2) = gg: fc = fc + 1
End If: End If
Next: Next
End If: End If
Next: Erase mtrx: Erase mtrx1: Erase gg
End Sub
Для повышения скорости нужно идти по пути реализованном в текстовом сортере ранее) Т.е. две матрицы 255х255 и большие затраты п памяти. Этот код ищет 10к элементов в массиве 500к примерно за 6 сек. Можно ускорить. По поисковику:
Скрытый текст
- в процедуру загружается список (массив) строк для поиска - массив, в котором ищем - номер столбца в массиве - ссылка на выходной массив результатов поиска - счетчик найденных элементов
Выходной массив результатов поиска представляет из себя список, где: - по каждому индексу первичного поискового массива строк указывается число найденных элементов - -------//--------- собственно список индексов в основном массиве
Jack Famous написал: разобрался как работает функция, получил из строки массив типа Byte с кодами символов, но как их дальше сравнивать не понимаю…
Вот еще одна функция для поиска одного байтового массива в другом с примером ее применения
Код
Sub qwe()
Dim aa() As Byte, zz() As Byte
e$ = "asdfghj"
aa = StrConv(e, 128)
zz = StrConv(Left$(e, 2), 128)
x = Asc(e)
If InStrB(1, aa, zz, 0) > 0 Then b = 1
End Sub
Измененный вариант. Памяти жрет больше, но и работает в сотню раз быстрее:
Скрытый текст
Код
Sub TxtFinder(txt$(), mass(), ByVal n%, arr, fc&)
Dim ll&, hh&, dt$, cc As Byte, a&, i%, j%, x&, gg&(), mtrx(), mtrx1(), bb() As Byte, ch1 As Byte, ch2 As Byte
ll = LBound(mass, 1): hh = UBound(mass, 1)
ReDim arr(LBound(txt) To UBound(txt), 1 To 2) 'кол-во найденных элементов, одномерный массив индексов
ReDim mtrx(32 To 255, 32 To 255)
For a = LBound(txt) To UBound(txt)
ch1 = Asc(txt(a))
If Len(txt(a)) > 1 Then ch2 = Asc(Mid(txt(a), 2, 1)) Else ch2 = 32
mtrx(ch1, ch2) = mtrx(ch1, ch2) + 1
Next
For a = LBound(txt) To UBound(txt) 'индексируем (разбиваем по 1-му символу поисковые строки)
ch1 = Asc(txt(a))
If Len(txt(a)) > 1 Then ch2 = Asc(Mid(txt(a), 2, 1)) Else ch2 = 32
If Not IsArray(mtrx(ch1, ch2)) Then
ReDim gg(1 To mtrx(ch1, ch2) + 1)
gg(1) = 2: gg(2) = a: mtrx(ch1, ch2) = gg()
Else
mtrx(ch1, ch2)(1) = mtrx(ch1, ch2)(1) + 1
mtrx(ch1, ch2)(mtrx(ch1, ch2)(1)) = a
End If
Next
ReDim mtrx1(32 To 255, 32 To 255)
For a = ll To hh 'индексация (разбиваем по 1-му символу строки опорного столбца входного массива )
ch1 = Asc(mass(a, n))
If Len(mass(a, n)) > 1 Then ch2 = Asc(Mid(mass(a, n), 2, 1)) Else ch2 = 32
mtrx1(ch1, ch2) = mtrx1(ch1, ch2) + 1
Next
For a = ll To hh
ch1 = Asc(mass(a, n))
If Len(mass(a, n)) > 1 Then ch2 = Asc(Mid(mass(a, n), 2, 1)) Else ch2 = 32
If IsArray(mtrx(ch1, ch2)) Then
If Not IsArray(mtrx1(ch1, ch2)) Then
ReDim gg(1 To mtrx1(ch1, ch2) + 1)
gg(2) = a: gg(1) = 2: mtrx1(ch1, ch2) = gg()
Else
mtrx1(ch1, ch2)(1) = mtrx1(ch1, ch2)(1) + 1
mtrx1(ch1, ch2)(mtrx1(ch1, ch2)(1)) = a
End If
End If
Next
For i = 32 To 255: For j = 32 To 255
If IsArray(mtrx(i, j)) Then
If IsArray(mtrx1(i, j)) Then
For a = 2 To mtrx(i, j)(1)
dt = txt(mtrx(i, j)(a))
For x = 2 To mtrx1(i, j)(1)
If dt = mass(mtrx1(i, j)(x), n) Then
arr(mtrx(i, j)(a), 1) = arr(mtrx(i, j)(a), 1) + 1
If Not IsArray(arr(mtrx(i, j)(a), 2)) Then
ReDim gg(1 To 1): gg(1) = mtrx1(i, j)(x)
arr(mtrx(i, j)(a), 2) = gg(): fc = fc + 1
Else
gg = arr(mtrx(i, j)(a), 2)
ReDim Preserve gg(1 To arr(mtrx(i, j)(a), 1))
gg(arr(mtrx(i, j)(a), 1)) = mtrx1(i, j)(x)
arr(mtrx(i, j)(a), 2) = gg: fc = fc + 1
End If
End If
Next
Next
End If: End If
Next: Next: Erase mtrx: Erase mtrx1: Erase gg
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
да нет - я следил за темой сортировки))) разница огромная, ведь я только совсем немного пишу)) подскажите пожалуйста - у макроса во входящих данных такие переменные: txt(), mass(), n%, arr, fc& - какая из них, для чего? В код лезть не буду - я там мало что понимаю))) матрицы всякие, 32 - 255 (это типа коды символов) и прочее
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, гляньте в посте #11 А в код лезть придется, если хотите научиться) Да, и там в коде нет проверки на пустые строки ни в поисковом списке, ни в проверяемом столбце массива.
это не страшно)) мне проще проверить оба диапазона перед запуском вашего макроса двумя строчками своей функции)) по остальному: буду изучать) Спасибо вам!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Вообще смысл этой процедуры - сравнить два списка, и если во втором есть значения первого, то вывести индексы строк с совпадениями. А дальше уже человеку использующему процедуру решать как с этими данными поступать. Для единичного ВПР список из одного значения.
Anchoret, я прямо постараюсь разобраться) хоть и страшно))) буду писать сюда по мере продвижения
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Не, искать этой процедурой по одному - слишком долго. Даже заточенным под одиночный поиск вариантом:
Код
Function sTxtFinder(txt$, mass(), ByVal n%, SResult&()) As Boolean
Dim ll&, hh&, cc As Byte, cc1 As Byte, a&, x&, dt1$
ReDim SResult(1 To 1) 'одномерный массив индексов
If txt = "" Then sTxtFinder = False: Exit Function
dt1 = UCase(txt): cc = Asc(dt1)
If Len(txt) > 1 Then cc1 = Asc(Mid(dt1, 2, 1))
ll = LBound(mass, 1): hh = UBound(mass, 1): x = 1
For a = ll To hh
If Len(mass(a, n)) = Len(dt1) Then
If Asc(UCase(mass(a, n))) = cc Then
If Len(mass(a, n)) = 1 Then GoTo lp1
If Asc(UCase(Mid(mass(a, n), 2, 1))) = cc1 Then
lp1: If dt1 = UCase(mass(a, n)) Then
ReDim Preserve SResult(1 To x)
SResult(x) = a: x = x + 1
End If
End If
End If
End If
Next
If SResult(1) = 0 Then sTxtFinder = False Else sTxtFinder = True
End Function
Единственное, что приходит в голову - ВПРить по кнопке и сразу по нескольким столбцам, с массовой выгрузкой данных в поисковые массивы.
я так понимаю, что эта функция просто определяет, есть ли данное значение в массиве?… Она ж булевая.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
у меня глючит окно комментариев)) печатать очень неудобно) параметры говорят, что нужно передать следующее: txt$ — строку, которую ищем mass() — динамический неопределённый массив, где искать строку ByVal n% — непонятная до сих пор вещь))) as Integer, переданная значением, а не ссылкой SResult&() — динамический неопределённый массив результатов As Long
как-то так я вижу))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
вот мой вариант ВПР на массивах - ощущаемая скорость ниже гибрида Match с "тупым" перебором
Код
Public Function MassVPR(ByVal txt As String, ByRef rngSearch As Range, ByRef rngResult As Range)
Dim arrSrch, arrRes
Dim i&
arrSrch = rngSearch.Value2: arrRes = rngResult.Value2
For i = 1 To UBound(arrSrch, 1)
If arrSrch(i, 1) = txt Then MassVPR = arrRes(i, 1): Exit Function
Next i
End Function
думаю, если заменить "тупой" перебор на эти массивы, оставив Match, то скорость будет выше. Реализация максимально простая. «Надёжная, блин, как швейцарские часы» и понятная мне))) Продолжаю разбираться с бинарным поиском и ищу альтернативы))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
есть идея каким-то образом использовать вот такие функции
Код
Public Function PRDX_CheckByListAll(WF_Check As Range, WF_List As Range) As String
Dim WF_cl As Range
Dim WF_delim$, WF_strList$, WF_strCheck$, WF_rez$
Dim i&
On Error GoTo er
WF_delim = "•••"
WF_strList = xlVBA_Range2TXT(WF_List, WF_delim, WF_delim, WF_delim)
WF_strList = WF_delim & xlVBA_ReplaceOfficeSymbols(WF_strList) & WF_delim
For Each WF_cl In WF_Check
WF_strCheck = "*" & WF_delim & xlVBA_ReplaceOfficeSymbols(WF_cl) & WF_delim & "*"
If Not (WF_strList Like WF_strCheck) Then WF_rez = WF_rez & WF_delim & WF_cl.Value2
Next WF_cl
If WF_rez = "" Then PRDX_CheckByListAll = "ГОТОВО" Else: PRDX_CheckByListAll = Mid(WF_rez, Len(WF_delim) + 1)
GoTo fin
er:
PRDX_CheckByListAll = ""
fin:
End Function
'===================================================================================================================
Public Function PRDX_CheckByListOne(WF_cl As Range, WF_List As Range) As String
Dim WF_delim$, WF_strList$, WF_strCheck$
On Error GoTo er
WF_delim = "•••"
WF_strList = xlVBA_Range2TXT(WF_List, WF_delim, WF_delim, WF_delim)
WF_strList = WF_delim & xlVBA_ReplaceOfficeSymbols(WF_strList) & WF_delim
WF_strCheck = "*" & WF_delim & xlVBA_ReplaceOfficeSymbols(WF_cl) & WF_delim & "*"
If WF_strList Like WF_strCheck Then PRDX_CheckByListOne = "НАЙДЕНО": GoTo fin
er:
PRDX_CheckByListOne = ""
fin:
End Function
'===================================================================================================================
Public Function xlVBA_Range2TXT(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = "•", Optional ByVal RowsSeparator$ = "•", Optional ByVal AreasSeparator$ = "•") As String
Dim ar As Range
Dim arr
Dim i&, j&
Dim txt$
If ra.Cells.Count = 1 Then xlVBA_Range2TXT = ra.Value2: Exit Function
If ra.Areas.Count > 1 Then
For Each ar In ra.Areas
xlVBA_Range2TXT = xlVBA_Range2TXT & AreasSeparator$ & xlVBA_Range2TXT(ar, ColumnsSeparator$, RowsSeparator$)
Next ar
xlVBA_Range2TXT = Mid(xlVBA_Range2TXT, Len(AreasSeparator) + 1)
Exit Function
End If
arr = ra.Value
For i = LBound(arr, 1) To UBound(arr, 1)
txt = "": For j = LBound(arr, 2) To UBound(arr, 2): txt = txt & ColumnsSeparator$ & arr(i, j): Next j
xlVBA_Range2TXT = xlVBA_Range2TXT & Mid(txt, Len(ColumnsSeparator$) + 1) & RowsSeparator$
Next i
xlVBA_Range2TXT = Left(xlVBA_Range2TXT, Len(xlVBA_Range2TXT) - 1)
End Function
'===================================================================================================================
Function xlVBA_ReplaceOfficeSymbols(ByVal WF_txt As String, Optional FileSymbols As Boolean = False) As String
Dim WF_arr
Dim WF_str$
Dim WF_i%
If FileSymbols = True Then
WF_str = "~!@/\#$%^&*=|`"""
For WF_i = 1 To Len(WF_str)
WF_txt = Replace(WF_txt, Mid(WF_str, WF_i, 1), "")
Next WF_i
Else
WF_str = "~!?#*()[]{}`"""
WF_arr = Array("tld", "vskl", "vprs", "rshtk", "zvzd", "skbkrl", "skbkrp", "skbkvl", "skbkvp", "skbfgl", "skbfgp", "pstrf2", "kvchk")
For WF_i = 1 To Len(WF_str)
WF_txt = Replace(WF_txt, Mid(WF_str, WF_i, 1), WF_arr(WF_i - 1))
WF_txt = Replace(WF_txt, Chr(39), "pstrf1") 'замена апострофа
Next WF_i
End If
xlVBA_ReplaceOfficeSymbols = WF_txt
End Function
они супермегабыстрые и позволяют либо проверить конкретное значение на соответствие списку, либо сразу весь диапазон проверить и вывести в текстовую строку с разделителями все несоответствия основано на методе, отсюда. Проблема в том, что проверяется только наличие или отсутствие и для своих задач вполне подходит. Однако до индекса никак не добраться((( прошу прощения, что "простыня" кодов не под спойлером - не могу "нащупать" кнопку. Панель не отображается
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
я прошу прощения за сумбур)) просто сортировка была первым моим предполагаемым решением проблемы. При этом в шапке я подчеркнул, какие задачи хочу решить. Дело ещё в том, что сейчас для подсчёта количества дублей я "тупо" макросом сортирую "умную" таблицу и циклом считаю повторы. Вот и предположил, что сортировка массива, полученного из диапазона будет намного лучше. Но это, повторюсь, лишь один из способов решения проблемы.
Спасибо вам)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
вот. только к #27 я понял о чем речь. (допустим, это личная проблема) но общая проблема в том, что в названии темы нужно описывать задачу, которую Вы решаете, а не метод(ы), который(е) Вы используете для ее решения и, можно понять, когда на эти грабли наступают начинающие, но в данном случае, Jack Famous, я, мягко говоря, был удивлен
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!