СцепитьЕсли. Эффективный и универсальный алгоритм

СцепитьЕсли. Эффективный и универсальный алгоритм, JoinIf

Пользователь

Сообщений: 12149 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

02.05.2024 17:14:08

Приветствую!

Представляю 1 основной способ — Progressive.
+ один "в лоб" (для примера)
+ один — с помощью массивов, но он никуда не годится.
+ один на основе Mid$() =. От него ничего реально качественного добиться (для универсальности) не вышло. Наверное, что-то можно подкрутить.

Что не исследовано:
• метод скуля. То есть, отсортировать поле ключей и "сгруппировать" по ним, сцепляя строки.
• контроль уникальности сцепляемых строк. С учётом регистра и без него.

Что-то из этого или всё сразу будет во втором тесте — с победителями (Progressive и Middle).

Файл
JoinIf.xlsb (23.86 КБ)

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' aKeys_Out() and aJoin_Out() have LBound = 0
Sub Simple(a2Col_In, sSep_In$, aKeys_Out(), aJoin_Out())
Dim dic As New Dictionary
Dim s$, r&

For r = 1 To UBound(a2Col_In, 1)
    s = a2Col_In(r, 1)
    
    If dic.Exists(s) Then
        dic(s) = dic(s) & sSep_In & a2Col_In(r, 2)
    Else
        dic.Add s, a2Col_In(r, 2)
    End If
Next r

aKeys_Out = dic.Keys
aJoin_Out = dic.Items
End Sub
'==================================================================================================
Sub Progressive(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim s$, r&, n&, p&

r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)

For r = 1 To UBound(a2Col_In, 1)
    s = a2Col_In(r, 1)
    p = dic(s)
    
    If (p = 0) Then
        n = n + 1: dic(s) = n
        aKeys_Out(n) = s
        aJoin_Out(n) = a2Col_In(r, 2)
    Else
        aJoin_Out(p) = aJoin_Out(p) & sSep_In & a2Col_In(r, 2)
    End If
Next r

ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
Sub Middle(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim aPos&()
Dim s$, sps$, t!, r&, n&, p&, l&, lSep&, lPos&, ll&
Const lBuf& = 1000

sps = Space$(lBuf): lSep = Len(sSep_In): r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r), aPos(r)

't = Timer
    For r = 1 To UBound(a2Col_In, 1)
        s = a2Col_In(r, 1)
        p = dic(s)
        
        If (p = 0) Then
            n = n + 1: dic(s) = n
            aKeys_Out(n) = s
            
            s = a2Col_In(r, 2): l = Len(s)
            aJoin_Out(n) = sps
            Mid$(aJoin_Out(n), 1, l) = s
            
            aPos(n) = l
        Else
            s = a2Col_In(r, 2): l = Len(s)
            lPos = aPos(p):     ll = lPos + lSep + l
            
            If (ll > lBuf) Then
                aJoin_Out(p) = Left$(aJoin_Out(p), aPos(p)) & sSep_In & s
            Else
                Mid$(aJoin_Out(p), lPos + 1, lSep) = sSep_In
                Mid$(aJoin_Out(p), lPos + 1 + lSep, l) = s
            End If

            aPos(p) = ll
        End If
    Next r
'Debug.Print Round(Timer - t, 2), "Middle(Main)"

ReDim Preserve aKeys_Out(n), aJoin_Out(n)

't = Timer
    For n = 1 To n
        aJoin_Out(n) = Left$(aJoin_Out(n), aPos(n))
    Next n
'Debug.Print Round(Timer - t, 2), "Middle(Cut)"
End Sub
'==================================================================================================
Sub ArrJoin(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim aArr(), aJ$(), aJ2$(), aCnt&()
Dim s$, sps$, t!, r&, n&, p&, cnt&

r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aArr(r), aCnt(r)

r = r / 10: If (r < 1000) Then r = 1000
ReDim aJ(r)

t = Timer
    For r = 1 To UBound(a2Col_In, 1)
        s = a2Col_In(r, 1)
        p = dic(s)

        If (p = 0) Then
            n = n + 1: dic(s) = n
            aKeys_Out(n) = s

            aJ(1) = a2Col_In(r, 2): aArr(n) = aJ
            aCnt(n) = 1
        Else
            cnt = aCnt(n): aJ2 = aArr(n)
            If (cnt = UBound(aJ2)) Then ReDim Preserve aJ2(2 * cnt)
            cnt = cnt + 1: aCnt(n) = cnt
            aJ2(cnt) = a2Col_In(r, 2): aArr(n) = aJ2
        End If
        
        DoEvents
    Next r
Debug.Print Round(Timer - t, 2), "ArrJoin(Main)"

ReDim Preserve aKeys_Out(n)
ReDim aJoin_Out(n)

t = Timer
    For n = 1 To n
        aJ = aArr(n): ReDim Preserve aJ(aCnt(n))
        aJoin_Out(n) = Join(aJ, sSep_In)
    Next n
Debug.Print Round(Timer - t, 2), "ArrJoin(Cut)"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub CreateArr2Col(aOut, nUniq&, nRepeats&)
Dim n&, r&, p&

ReDim aOut(nUniq * (1 + nRepeats), 2)   ' Key, Value

For n = 1 To nUniq
    r = r + 1
    aOut(r, 1) = "Key_" & n
    aOut(r, 2) = "Val_" & r
    
    For p = 1 To nRepeats
        r = r + 1
        aOut(r, 1) = aOut(r - 1, 1)
        aOut(r, 2) = "Val_" & r
    Next p
Next n

End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim aK(), aV(), aKs$(), aVs$()
Dim a, t!
Const sep = ", "

t = Timer                                       ' Repeats
    CreateArr2Col a, 100000, 0                  ' 0   | 10  | 100
Debug.Print Round(Timer - t, 2), "CreateArr"    ' 0.1 | 0.4 | 3.5



t = Timer
    Simple a, sep, aK, aV
Debug.Print Round(Timer - t, 2), "Simple"       ' 0.3 | 0.8 | 6.5
'Debug.Print aK(99), "«" & aV(99) & "»"

t = Timer
    Progressive a, sep, aKs, aVs
Debug.Print Round(Timer - t, 2), "Progressive"  ' 0.2 | 0.6 | 4.7
'Debug.Print aKs(100), "«" & aVs(100) & "»"

t = Timer
    Middle a, sep, aKs, aVs
Debug.Print Round(Timer - t, 2), "Middle"       ' 0.3 | 0.6 | 4.0
'Debug.Print aKs(100), "«" & aVs(100) & "»"

't = Timer
'    ArrJoin a, sep, aKs, aVs
'Debug.Print Round(Timer - t, 2), "ArrJoin"     ' OUT !!!
''Debug.Print aKs(100), "«" & aVs(100) & "»"

End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================

Что нужно? Предложите более качественный алгоритм (возможно, на основе MidB() ).

Основная проблема: никогда заранее неизвестно, сколько уникальных ключей содержится в массиве и, сколько по каждому из них будет сцеплено значений. Массив может состоять только из ключей и тогда для каждого ключа будет только одно значение. Массив может состоять из одного ключа и тогда все значения нужно сцепить в одну строку (которая ещё может и не влезть в ячейку).

Если bedvit'у будет интересно, то предлагаю сделать такую процедуру — я протестирую.

В итоге, такая процедура должна принимать:

Возможно, имеет смысл сразу сделать комбайн (как для фильтра) — процедуру группировки двумерного массива со следующими аргументами:

Изменено: Jack Famous - 02.05.2024 17:27:39

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

Jack Famous

Пользователь

Сообщений: 12149 Регистрация: 07.11.2014

OS: Win 10 Корп. x64 | Excel 2016 x64: | Browser: Chrome

03.05.2024 16:08:16

Часть 2. Агрегация на отсортированном по ключам массиве
Без подключенной библы bedvit'а тут делать нечего — штатные сортеры уступают многократно и проигрывают, даже не начав сцепку.

Файл
JoinIf_2.xlsb (30.74 КБ)

Модули

Test

V_BedVit

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public BV As New BedvitCOM.VBA
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub Progressive_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim map As New BedvitCOM.UnorderedMap
Dim x, s$, r&, n&

r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)

For r = 1 To r
    s = a2Col_In(r, 1)

    If (map.Find(s, x)) Then
        aJoin_Out(x) = aJoin_Out(x) & sSep_In & a2Col_In(r, 2)
    Else
        n = n + 1: map.Insert s, n
        aKeys_Out(n) = s
        aJoin_Out(n) = a2Col_In(r, 2)
    End If
Next r

ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
Sub Sort_Join_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim a, aJ$(), sOld$, sNew$, t!, r&, n&, j&, UBnd&
Const UBcnst& = 100

't = Timer
    BV.ArraySortV a2Col_In
'Debug.Print Round(Timer - t, 2), "Sort_Join_BV(Sort)"   ' ~ 50% of TotalTime

r = UBound(a2Col_In, 1): UBnd = UBcnst
ReDim aKeys_Out(r), aJoin_Out(r), aJ(UBnd)

't = Timer
    sOld = a2Col_In(1, 1)
    j = 1: aJ(j) = a2Col_In(1, 2)

    For r = 2 To r
        sNew = a2Col_In(r, 1)
        
        If (sOld = sNew) Then
            If (j = UBnd) Then UBnd = 10 * UBnd: ReDim Preserve aJ(UBnd)
            j = j + 1: aJ(j) = a2Col_In(r, 2)
        Else
            n = n + 1
            aKeys_Out(n) = sOld: sOld = sNew
            ReDim Preserve aJ(j): aJoin_Out(n) = Join(aJ, sSep_In)
            If (UBnd <> UBcnst) Then UBnd = UBcnst: ReDim aJ(UBnd)
            j = 1: aJ(j) = a2Col_In(r, 2)
        End If
    Next r

    n = n + 1
    aKeys_Out(n) = sOld
    ReDim Preserve aJ(j): aJoin_Out(n) = Join(aJ, sSep_In)
'Debug.Print Round(Timer - t, 2), "Sort_Join_BV(Main)"   ' ~ 50% of TotalTime

ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
Sub Sort_Mid_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim sBuf$, sW$, sOld$, sNew$, t!, r&, n&, lS&, lW&, lP&, ll&
Const lB& = 32767

't = Timer
    BV.ArraySortV a2Col_In
'Debug.Print Round(Timer - t, 2), "Sort_Mid(Sort)"   ' ~ 40% of TotalTime

r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)

lS = Len(sSep_In)
sBuf = Space$(lB)

't = Timer
    sOld = a2Col_In(1, 1)
    sW = a2Col_In(1, 2): lW = Len(sW)
    Mid$(sBuf, 1, lW) = sW: lP = lW

    For r = 2 To r
        sNew = a2Col_In(r, 1)

        If (sOld = sNew) Then
            sW = a2Col_In(r, 2): lW = Len(sW)
            ll = lP + lS + lW: If (ll > lB) Then Stop: End

            Mid$(sBuf, lP + 1, lS) = sSep_In
            Mid$(sBuf, lP + 1 + lS, lW) = sW
            lP = ll
        Else
            n = n + 1
            aKeys_Out(n) = sOld: sOld = sNew
            aJoin_Out(n) = Left$(sBuf, lP)
            
            sW = a2Col_In(r, 2): lW = Len(sW)
            Mid$(sBuf, 1, lW) = sW: lP = lW
        End If
    Next r

    n = n + 1
    aKeys_Out(n) = sOld
    aJoin_Out(n) = Left$(sBuf, lP)

'Debug.Print Round(Timer - t, 2), "Sort_Mid(Main)"   ' ~ 60% of TotalTime

ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub CreateArr2Col(aOut, nUniq&, nRepeats&, Optional UnSort As Boolean)
Dim n&, r&, p&

If UnSort Then
    ReDim aOut(nUniq * (1 + nRepeats), 3)   ' Key, Value, Sort(Optional Temp)
Else
    ReDim aOut(nUniq * (1 + nRepeats), 2)
End If

For n = 1 To nUniq
    r = r + 1
    aOut(r, 1) = "Key_" & n
    aOut(r, 2) = "Val_" & r
    If UnSort Then aOut(r, 3) = Rnd()
    
    For p = 1 To nRepeats
        r = r + 1
        aOut(r, 1) = aOut(r - 1, 1)
        aOut(r, 2) = "Val_" & r
        If UnSort Then aOut(r, 3) = Rnd()
    Next p
Next n

If Not UnSort Then Exit Sub

BV.ArraySortV aOut, 3
ReDim Preserve aOut(UBound(aOut), 2)

End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================

V_PRDX

Код

Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub Progressive(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim s$, r&, n&, p&

r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)

For r = 1 To r
    s = a2Col_In(r, 1)
    p = dic(s)
    
    If (p = 0) Then
        n = n + 1: dic(s) = n
        aKeys_Out(n) = s
        aJoin_Out(n) = a2Col_In(r, 2)
    Else
        aJoin_Out(p) = aJoin_Out(p) & sSep_In & a2Col_In(r, 2)
    End If
Next r

ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
Sub Middle(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim aPos&()
Dim s$, sps$, t!, r&, n&, p&, l&, lSep&, lPos&, ll&
Const lBuf& = 1000

sps = Space$(lBuf): lSep = Len(sSep_In): r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r), aPos(r)

't = Timer
    For r = 1 To r
        s = a2Col_In(r, 1)
        p = dic(s)
        
        If (p = 0) Then
            n = n + 1: dic(s) = n
            aKeys_Out(n) = s
            
            s = a2Col_In(r, 2): l = Len(s)
            aJoin_Out(n) = sps
            Mid$(aJoin_Out(n), 1, l) = s
            
            aPos(n) = l
        Else
            s = a2Col_In(r, 2): l = Len(s)
            lPos = aPos(p):     ll = lPos + lSep + l
            
            If (ll > lBuf) Then
                aJoin_Out(p) = Left$(aJoin_Out(p), aPos(p)) & sSep_In & s
            Else
                Mid$(aJoin_Out(p), lPos + 1, lSep) = sSep_In
                Mid$(aJoin_Out(p), lPos + 1 + lSep, l) = s
            End If

            aPos(p) = ll
        End If
    Next r
'Debug.Print Round(Timer - t, 2), "Middle(Main)"

ReDim Preserve aKeys_Out(n), aJoin_Out(n)

't = Timer
    For n = 1 To n
        aJoin_Out(n) = Left$(aJoin_Out(n), aPos(n))
    Next n
'Debug.Print Round(Timer - t, 2), "Middle(Cut)"
End Sub
'==================================================================================================
'==================================================================================================

Изменено: Jack Famous - 03.05.2024 16:14:57

nilske

Пользователь

Сообщений: 837 Регистрация: 30.11.2018

03.05.2024 21:53:18

Jack Famous, вот вроде темы с интересными названиями создаёте, но как по мне, то код не особо располагает к его прочтению и изучению уже даже из за наименования переменных - они незатейливо "по-бырику" названы n, r, s, p и т.п.
Сугубо моё личное мнение, был бы рад если бы в этом плане что то поменялось и стало бы проще "дотянуться до звёзды"

Jack Famous Пользователь Сообщений: 12149 Регистрация: 07.11.2014 OS: Win 10 Корп. x64 \| Excel 2016 x64: \| Browser: Chrome	#4 03.05.2024 22:04:11 nilske, не считаю, что для счётчиков нужны длинные названия. Тем более, они могут менять свое назначение. А вообще, счётчики (как и остальные переменные) у меня и так по смыслу названы: r считает строки (Rows), c — столбцы (Columns), n — номера (Number), p — позиции (Positions). Двойные эти буквы тоже, как правило, несут смысл, схожий с одинарными. s — это вообще строковая переменная (String). Если человек по коду не может понять, что делает конкретная переменная, то тут я ему вряд ли помогу, хотя спросить можно. Возможно, для индивидуального удобства, вам стоит переименовать мои переменные в свои. Я так часто делаю с чужим кодом, чтобы читать было понятнее/привычнее. Изменено: Jack Famous - 03.05.2024 22:09:54 Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄