Страницы: 1
RSS
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
Всем добрый день!

Пожалуйста, помогите автоматизировать процесс переноса данных из одной таблицы в другую. Есть исходная таблица, "откуда" надо перенести данные, есть таблица, "куда" надо перенести. Поиск производится по полю "адрес". При этом количество строк для одного и того же адреса в обеих таблицах разное, а так же есть адреса, которые присутствуют в одной и отсутствуют в другой. В таблице "куда" количество строк изменять нельзя.

Если в таблице "откуда" количество строк для одного адреса больше, чем в таблице "куда", то данные по номеру и дате платежа для лишних строк переносятся через "запятую с пробелом" в последнюю найденную строку данного адреса таблицы "куда", а назначение платежа берется из последней найденной строки.

Если наоборот, в таблице "откуда" количество строк для одного адреса меньше, чем в таблице "куда", то пустые ячейки заполняются нолями.

В случае полного соответствия количества строк по одному адресу в обеих таблицах данные переносятся как есть.

Для наглядности пример во вложении.


Заранее благодарю за любой совет. Пока перенесла данные по полному соответствию строк, а так же при разнице в 1 строку. Остальные случаи занимают слишком много времени. А строк надо перенести 15 000 :(
Изменено: Анастасия Тюрькова - 21.11.2022 16:13:02
 
Код
Sub myCopy()
    Dim dicFrom As Object
    Dim dicTarg As Object
    Dim rTarg As Range
    
    Set dicFrom = GetDicFrom(Sheets("откуда"))
    If dicFrom Is Nothing Then Exit Sub
    Set dicTarg = GetDicTarg(Sheets("куда"), rTarg)
    If dicTarg Is Nothing Then Exit Sub
    
    Dim arr As Variant
    Dim brr As Variant
    arr = rTarg
    
    Dim flag As Boolean
    Dim xx As Long
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            flag = False
            If dicFrom.Exists(arr(yy, 1)) Then
                If dicFrom.Item(arr(yy, 1)).Count > 0 Then
                    brr = dicFrom.Item(arr(yy, 1)).Items()(0)
                    For xx = 2 To UBound(arr, 2)
                        arr(yy, xx) = brr(xx - 2)
                    Next
                    dicFrom.Item(arr(yy, 1)).Remove dicFrom.Item(arr(yy, 1)).Keys()(0)
                    flag = True
                End If
            End If
            If flag = False Then
                For xx = 2 To UBound(arr, 2)
                    arr(yy, xx) = 0
                Next
            End If
        End If
    Next
    rTarg = arr
    
End Sub

Private Function GetDicFrom(sh As Worksheet) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        arr = .Range(.Cells(3, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            Set bic = dic.Item(arr(yy, 1))
            bic.Item(bic.Count) = Array(arr(yy, 2), arr(yy, 3), arr(yy, 4))
            Set dic.Item(arr(yy, 1)) = bic
        End If
    Next
    
    Set GetDicFrom = dic
End Function

Private Function GetDicTarg(sh As Worksheet, rr As Range) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        Set rr = .Range(.Cells(3, 1), .Cells(yy, 4))
        arr = .Range(.Cells(1, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 3 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            Set bic = dic.Item(arr(yy, 1))
            bic.Item(bic.Count) = yy
            Set dic.Item(arr(yy, 1)) = bic
        End If
    Next
    
    Set GetDicTarg = dic
End Function
Без пункта "Если в таблице "откуда" количество строк для одного адреса больше, чем в таблице "куда"
 
Код
'v2
Sub myCopy()
    Dim dicFrom As Object
    Dim dicTarg As Object
    Dim rTarg As Range
    
    Set dicFrom = GetDicFrom(Sheets("откуда"))
    If dicFrom Is Nothing Then Exit Sub
    Set dicTarg = GetDicTarg(Sheets("куда"), rTarg)
    If dicTarg Is Nothing Then Exit Sub
    
    Dim arr As Variant
    Dim brr As Variant
    arr = rTarg
    
    Dim flag As Boolean
    Dim xx As Long
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            flag = False
            If dicFrom.Exists(arr(yy, 1)) Then
                If dicFrom.Item(arr(yy, 1)).Count > 0 Then
                    brr = dicFrom.Item(arr(yy, 1)).Items()(0)
                    For xx = 2 To UBound(arr, 2)
                        arr(yy, xx) = brr(xx - 2)
                    Next
                    dicFrom.Item(arr(yy, 1)).Remove dicFrom.Item(arr(yy, 1)).Keys()(0)
                    If dicFrom.Item(arr(yy, 1)).Count = 0 Then dicFrom.Remove (arr(yy, 1))
                    flag = True
                End If
            End If
            If flag = False Then
                For xx = 2 To UBound(arr, 2)
                    arr(yy, xx) = 0
                Next
            End If
        End If
    Next
    If dicFrom.Count > 0 Then
        Dim vKey As Variant
        For Each vKey In dicFrom.Keys
            If dicTarg.Exists(vKey) Then
                yy = dicTarg.Item(vKey)
                Do
                    If dicFrom.Item(vKey).Count = 0 Then Exit Do
                    brr = dicFrom.Item(vKey).Items()(0)
                    For xx = 2 To UBound(arr, 2)
                        arr(yy, xx) = arr(yy, xx) & ", " & brr(xx - 2)
                    Next
                    dicFrom.Item(vKey).Remove dicFrom.Item(vKey).Keys()(0)
                Loop
            End If
        Next
    End If
    
    rTarg = arr
    
End Sub

Private Function GetDicFrom(sh As Worksheet) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        arr = .Range(.Cells(3, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            Set bic = dic.Item(arr(yy, 1))
            bic.Item(bic.Count) = Array(arr(yy, 2), arr(yy, 3), arr(yy, 4))
            Set dic.Item(arr(yy, 1)) = bic
        End If
    Next
    
    Set GetDicFrom = dic
End Function

Private Function GetDicTarg(sh As Worksheet, rr As Range) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        Set rr = .Range(.Cells(3, 1), .Cells(yy, 4))
        arr = .Range(.Cells(1, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 3 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
'            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
'            Set bic = dic.Item(arr(yy, 1))
'            bic.Item(bic.Count) = yy
'            Set dic.Item(arr(yy, 1)) = bic
            dic.Item(arr(yy, 1)) = yy
        End If
    Next
    
    Set GetDicTarg = dic
End Function
 
Del
Изменено: New - 22.11.2022 03:18:58
 
МатросНаЗебре, я разобралась, все получилось на примере. Однако, при запуске макроса программа пожаловалась Run time error 9/ Subscript out of range, теперь пишет can't execute code in break, и в теле макроса выделил  цветом 49 строку кода 'V2' arr(yy, xx) = arr(yy, xx) & ", " & brr(xx - 2). Предполагаю, что при соединении лишних строк из таблицы "откуда" в колонке "назначение платежа" получается слишком длинное значение. Можно ли упростить эту задачу для колонки "назначение платежа", чтобы при нахождении лишних строк для одного адреса в таблице "откуда" в эту колонку возвращалось лишь одно значение в таблицу "куда" (любое из найденных лишних строк).

Заранее благодарю!!
Изменено: Анастасия Тюрькова - 22.11.2022 10:00:34
 
В этом варианте не дописывается "назначение платежа". Предположу, что дело было не в длине строки, скорее всего, закралось какое-то ошибочное значение.
Код
'v3
Sub myCopy()
    Dim dicFrom As Object
    Dim dicTarg As Object
    Dim rTarg As Range
    
    Set dicFrom = GetDicFrom(Sheets("откуда"))
    If dicFrom Is Nothing Then Exit Sub
    Set dicTarg = GetDicTarg(Sheets("куда"), rTarg)
    If dicTarg Is Nothing Then Exit Sub
    
    Dim arr As Variant
    Dim brr As Variant
    arr = rTarg
    
    Dim flag As Boolean
    Dim xx As Long
    Dim yy As Long
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            flag = False
            If dicFrom.Exists(arr(yy, 1)) Then
                If dicFrom.Item(arr(yy, 1)).Count > 0 Then
                    brr = dicFrom.Item(arr(yy, 1)).Items()(0)
                    For xx = 2 To UBound(arr, 2)
                        arr(yy, xx) = brr(xx - 2)
                    Next
                    dicFrom.Item(arr(yy, 1)).Remove dicFrom.Item(arr(yy, 1)).Keys()(0)
                    If dicFrom.Item(arr(yy, 1)).Count = 0 Then dicFrom.Remove (arr(yy, 1))
                    flag = True
                End If
            End If
            If flag = False Then
                For xx = 2 To UBound(arr, 2)
                    arr(yy, xx) = 0
                Next
            End If
        End If
    Next
    If dicFrom.Count > 0 Then
        Dim vKey As Variant
        For Each vKey In dicFrom.Keys
            If dicTarg.Exists(vKey) Then
                yy = dicTarg.Item(vKey)
                Do
                    If dicFrom.Item(vKey).Count = 0 Then Exit Do
                    brr = dicFrom.Item(vKey).Items()(0)
                    For xx = 2 To UBound(arr, 2) - 1
                        arr(yy, xx) = arr(yy, xx) & ", " & brr(xx - 2)
                    Next
                    dicFrom.Item(vKey).Remove dicFrom.Item(vKey).Keys()(0)
                Loop
            End If
        Next
    End If
    
    rTarg = arr
    
End Sub

Private Function GetDicFrom(sh As Worksheet) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        arr = .Range(.Cells(3, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 1 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
            Set bic = dic.Item(arr(yy, 1))
            bic.Item(bic.Count) = Array(arr(yy, 2), arr(yy, 3), arr(yy, 4))
            Set dic.Item(arr(yy, 1)) = bic
        End If
    Next
    
    Set GetDicFrom = dic
End Function

Private Function GetDicTarg(sh As Worksheet, rr As Range) As Object
    Dim dic As Object
    Dim yy As Long
    Dim arr As Variant
    
    With sh
        yy = .Cells(.Rows.Count, 1).End(xlUp).Row
        If yy < 3 Then Exit Function
        Set rr = .Range(.Cells(3, 1), .Cells(yy, 4))
        arr = .Range(.Cells(1, 1), .Cells(yy, 4))
    End With
    
    Dim bic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For yy = 3 To UBound(arr, 1)
        If Not IsEmpty(arr(yy, 1)) Then
'            If Not dic.Exists(arr(yy, 1)) Then Set dic.Item(arr(yy, 1)) = CreateObject("Scripting.Dictionary")
'            Set bic = dic.Item(arr(yy, 1))
'            bic.Item(bic.Count) = yy
'            Set dic.Item(arr(yy, 1)) = bic
            dic.Item(arr(yy, 1)) = yy
        End If
    Next
    
    Set GetDicTarg = dic
End Function
 
К сожалению, на моей таблице срабатывает только первый вариант макроса. Прикрепить таблицу не могу - слишком много весит :( Уточню, что я не сильна в макросах, возможно, проблема в типе файла, хотя я его сохранила как "с поддержкой макросов".  
Изменено: Анастасия Тюрькова - 22.11.2022 11:21:00
 
Анастасия, добрый день! Вариант:
Код
Sub fill_table()
Dim arr As Variant, data_arr As Variant, from As Object, data As Object, lr As Long
Dim i As Variant, j, k, t
With Worksheets("куда") ' куда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A3:A" & lr)
    Set data = count_arr(arr)
    arr = .Cells(2, 1).CurrentRegion
End With

With Worksheets("откуда") ' откуда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    data_arr = .Range("A3:A" & lr)
    Set from = count_arr(data_arr)
    data_arr = .Cells(2, 1).CurrentRegion
End With
For Each i In data.keys()
If Not IsEmpty(data(i)) And Not IsEmpty(from(i)) Then
k = linear_search(arr, 1, i)
t = linear_search(data_arr, 1, i)
    If data(i) = from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
    ElseIf data(i) > from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        Do
            arr(k, 2) = 0
            arr(k, 3) = 0
            arr(k, 4) = 0
            k = k + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        
    Else
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        k = k - 1
        Do
            arr(k, 2) = arr(k, 2) & ", " & data_arr(t, 2)
            arr(k, 3) = arr(k, 3) & ", " & data_arr(t, 3)
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        arr(k, 4) = data_arr(t - 1, 4)
    End If
Else
    k = linear_search(arr, 1, i)
    Do
        For j = 2 To UBound(arr, 2)
            arr(k, j) = 0
        Next j
        k = k + 1
        If k > UBound(arr, 1) Then Exit Do
    Loop While arr(k, 1) = i
End If
Next i
' выгрузка результата
With Worksheets("res") ' res - это имя листа то имя листа с результатом
    .Cells.Clear
    lr = 1
    .Columns(1).NumberFormat = "@"
    MsgBox "Начата выгрузка на лист res..."
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 1) To UBound(arr, 2)
            .Cells(lr + 1, j) = arr(i, j)
        Next j
        lr = lr + 1
    Next i
    MsgBox "Выгрузка закончена!"
End With
End Sub
Function count_arr(arr) As Object
Dim i, j, d As Object, c As Long
Set d = CreateObject("Scripting.Dictionary")
c = 1
For i = 2 To UBound(arr, 1)
    j = i - 1
    If arr(i, 1) = arr(j, 1) Then
        c = c + 1
    Else
        d.Add CStr(arr(j, 1)), c
        c = 1
    End If
Next i
j = i - 1
d.Add arr(j, 1), c
Set count_arr = d
End Function
Private Function linear_search(arr, i, what) As Long
Dim j
linear_search = -1
For j = LBound(arr, 1) To UBound(arr, 1)
    If arr(j, i) = what Then linear_search = j: Exit Function
Next j
End Function


Результат - на листе "res". Макрос требует предварительной сортировки по первому столбцу (с лицевым счётом!!!)
Предполагается, что данные в обоих таблицах начинаются с 3 строки
Изменено: artemkau88 - 24.11.2022 08:45:41
 
artemkau88, спасибо большое, все сработало! Вероятно, я не правильно записывала макрос с кодом выше. Очень выручили!
 
Анастасия, пожалуйста! Успехов Вам! :)  
 
artemkau88, добрый день! Могу я уточнить такой момент: если мне необходимо будет подтягивать данные не по текстовому полю (как по адресу), а по лицевому счету, например, надо ли менять код макроса? Я попробовала в колонку "адрес" вбить лицевые счета, которые состоят из 10 цифр, но формат ячеек при этом у них был текстовый, и макрос не сработал.
 
Анастасия, добрый день! У меня корректно отработал при формате текстовых значений в первом столбце 2-х таблиц, даже с нулями в начале и с цифрами тоже корректно (вбивал 10-ти значные цифры). Результат смотрите на листе res? Данные лицевых счетов находятся в первом столбце в обоих таблицах, как в примере?

P.S.
забыл написать важный момент: данные в обоих таблицах должны быть отсортированы в порядке возрастания по первому столбцу ( с адресом (лицевым счетом))
Обновил файл с макросом в сообщении #8
Изменено: artemkau88 - 23.11.2022 10:44:45
 
Либо без предварительной сортировки первых столбцов (сортировка происходит в макросе). Результат - отсортированный по первому столбцу заполненный массив

Добавил вариант с сортировкой слиянием:  "Образец_3_merge_sort.xlsb" (также добавил уведомлялки с началом и окончанием выгрузки на лист "res")
Изменено: artemkau88 - 26.11.2022 09:49:07
 
artemkau88, спасибо, что предупредили про сортировку. Переделаю ))))) второй вариант макроса сильно затормозил работу компьютера - тяжело ему сортировать по алфавиту такой большой массив. Но сохраню для меньших списков, спасибо!! А вот первый при внесении 45 000 строк лицевых счетов выдает вот такую ошибку: "This key is already associated with an element of this collection". При этом, когда я сокращаю список, допустим, до 500 строк - работает. Каковы могут быть причины?  
 
Цитата
написал:
Каковы могут быть причины?  
нужно предварительно отсортировать и первую и вторую таблицу по первому столбцу. Это из - за функции подсчета значений. Обновил файл и код в сообщении #8
Цитата
написал:
тяжело ему сортировать по алфавиту такой большой массив
Можете подсказать максимальный объем строк в массиве? Спасибо!

P.S:
добавил в предыдущее сообщение файл Образец_3_merge_sort.xlsb, проверьте, быстрее ли работает? У меня на 50_000 строк достаточно быстро.

Этот макрос подразумевает, что данные в первой и второй таблице начинаются с 3 строки, как в примере (после шапки):
Код
For i = 2 To UBound(arr, 1) - 2 ' здесь вычитаются 2 строки шапки таблицы, т.к данные начинаются с 3 строки

код всей процедуры из файла "Образец_3_merge_sort.xlsb":
Код
Sub fill_table()
Dim arr As Variant, data_arr As Variant, from As Object, data As Object, lr As Long
Dim i As Variant, j, k, t, q
q = Timer
With Worksheets("куда") ' куда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A3:A" & lr)
    Set data = count_arr(recursive_merge_sort_2d_array(arr, 1))
    arr = .Cells(2, 1).CurrentRegion: arr = recursive_merge_sort_2d_array(arr, 1)
End With

With Worksheets("откуда") ' откуда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    data_arr = .Range("A3:A" & lr)
    Set from = count_arr(recursive_merge_sort_2d_array(data_arr, 1))
    data_arr = .Cells(2, 1).CurrentRegion: data_arr = recursive_merge_sort_2d_array(data_arr, 1)
End With
Debug.Print Timer - q
For Each i In data.keys()
If Not IsEmpty(data(i)) And Not IsEmpty(from(i)) Then
k = linear_search(arr, 1, i)
t = linear_search(data_arr, 1, i)
    If data(i) = from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
    ElseIf data(i) > from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        Do
            arr(k, 2) = 0
            arr(k, 3) = 0
            arr(k, 4) = 0
            k = k + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        
    Else
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        k = k - 1
        Do
            arr(k, 2) = arr(k, 2) & ", " & data_arr(t, 2)
            arr(k, 3) = arr(k, 3) & ", " & data_arr(t, 3)
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        arr(k, 4) = data_arr(t - 1, 4)
    End If
Else
    k = linear_search(arr, 1, i)
    Do
        For j = 2 To UBound(arr, 2)
            arr(k, j) = 0
        Next j
        k = k + 1
        If k > UBound(arr, 1) Then Exit Do
    Loop While arr(k, 1) = i
End If
Next i
' выгрузка результата
With Worksheets("res") ' res - это имя листа то имя листа с результатом
    .Cells.Clear
    .Columns(1).NumberFormat = "@"
    lr = 1
    MsgBox "Начата выгрузка данных на лист res, подождите....."
    For i = 2 To UBound(arr, 1) - 2 ' здесь вычитаются 2 строки шапки таблицы, т.к данные начинаются с 3 строки
        For j = LBound(arr, 2) To UBound(arr, 2)
            .Cells(lr + 1, j) = arr(i, j)
        Next j
        lr = lr + 1
    Next i
    MsgBox "Выгрузка данных завершена!"
End With
End Sub
Private Function count_arr(arr) As Object
Dim i, j, d As Object, c As Long
Set d = CreateObject("Scripting.Dictionary")
c = 1
For i = 2 To UBound(arr, 1)
    j = i - 1
    If arr(i, 1) = arr(j, 1) Then
        c = c + 1
    Else
        d.Add CStr(arr(j, 1)), c
        c = 1
    End If
Next i
j = i - 1
d.Add arr(j, 1), c
Set count_arr = d
End Function
Private Function linear_search(arr, i, what) As Long
Dim j
linear_search = -1
For j = LBound(arr, 1) To UBound(arr, 1)
    If arr(j, i) = what Then linear_search = j: Exit Function
Next j
End Function
Private Function merge(a, b, colToSort As Long) As Variant
    Dim arr(), p, i As Long, j As Long, k As Long
    p = UBound(a, 1) + UBound(b, 1)
    ReDim arr(1 To p, 1 To UBound(a, 2)): i = 1: j = 1
    For k = 1 To p
        If i > UBound(a, 1) Then
            For d = 1 To UBound(b, 2)
                arr(k, d) = CStr(b(j, d))
            Next d
                j = j + 1
        ElseIf j > UBound(b, 1) Then
            For d = 1 To UBound(a, 2)
                arr(k, d) = CStr(a(i, d))
            Next d
            i = i + 1
        Else
            If a(i, colToSort) < b(j, colToSort) Then
                For d = 1 To UBound(a, 2)
                    arr(k, d) = CStr(a(i, d))
                Next d
                i = i + 1
            Else
                For d = 1 To UBound(b, 2)
                    arr(k, d) = CStr(b(j, d))
                Next d
                j = j + 1
            End If
        End If
    Next k
    merge = arr
End Function
Private Function recursive_merge_sort_2d_array(arr, colToSort As Long) As Variant
    Dim q As Long, k As Long, j As Long
    Dim a(), b()
    Dim d As Long
    If UBound(arr, 1) > 1 Then
        If UBound(arr) Mod 2 = 0 Then
            q = Int(UBound(arr) / 2)
            ReDim a(1 To q, 1 To UBound(arr, 2)): ReDim b(1 To q, 1 To UBound(arr, 2))
        Else
            q = Int(UBound(arr) / 2)
            ReDim a(1 To q, 1 To UBound(arr, 2)): ReDim b(1 To q + 1, 1 To UBound(arr, 2))
        End If
        k = 1: j = 1
        For i = LBound(arr, 1) To UBound(arr, 1)
            If i <= q Then
                For d = 1 To UBound(arr, 2)
                    a(j, d) = CStr(arr(i, d))
                Next d
                    j = j + 1
            Else
                For d = 1 To UBound(arr, 2)
                    b(k, d) = CStr(arr(i, d))
                Next d
                k = k + 1
            End If
        Next i
        a = recursive_merge_sort_2d_array(a, colToSort)
        b = recursive_merge_sort_2d_array(b, colToSort)
        arr = merge(a, b, colToSort)
    End If
    recursive_merge_sort_2d_array = arr
End Function


Изменено: artemkau88 - 26.11.2022 09:41:48
 
Добавил еще вариант без предварительной сортировки. Сортируется запросом SQL в макросе.
Важно (см. зеленый комментарий в функции ниже):
Код
Function select_(sheet_name) As Variant
Dim mySQL As String, myConnect As String, myRecord As Object
Dim oRange As Range, QT As QueryTable, res, lr As Long
Set myRecord = CreateObject("ADODB.Recordset")
lr = Worksheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row
Set oRange = Worksheets(sheet_name).Range("A3:D" & lr) ' задается диапазон значений: здесь диапазон = А3:D26 (lr = 26) lr - менять не нужно, только цифру поле А

myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=NO;"""
mySQL = "SELECT [F1], [F2], [F3], [F4] FROM [" & sheet_name & "$" & oRange.Address(0, 0) & "] ORDER BY [F1] "
myRecord.Open mySQL, myConnect
res = myRecord.getrows()
select_ = res
myRecord.Close
Set myRecord = Nothing
End Function
Предпологается, что диапазон значений в таблицах "куда" и "откуда" начинается с А3

Код
Sub fill_table()
Dim arr As Variant, data_arr As Variant, from As Object, data As Object, lr As Long
Dim i As Variant, j, k, t
With Worksheets("куда") ' куда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = select_(.Name)
    Set data = count_arr(arr)
    arr = transpose_arr(arr)
End With

With Worksheets("откуда") ' откуда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    data_arr = select_(.Name)
    Set from = count_arr(data_arr)
    data_arr = transpose_arr(data_arr)
End With
For Each i In data.keys()
If Not IsEmpty(data(i)) And Not IsEmpty(from(i)) Then
k = linear_search(arr, 1, i)
t = linear_search(data_arr, 1, i)
    If data(i) = from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
    ElseIf data(i) > from(i) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        Do
            arr(k, 2) = 0
            arr(k, 3) = 0
            arr(k, 4) = 0
            k = k + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        
    Else
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = i
        k = k - 1
        Do
            arr(k, 2) = arr(k, 2) & ", " & data_arr(t, 2)
            arr(k, 3) = arr(k, 3) & ", " & data_arr(t, 3)
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = i
        arr(k, 4) = data_arr(t - 1, 4)
    End If
Else
    k = linear_search(arr, 1, i)
    Do
        For j = 2 To UBound(arr, 2)
            arr(k, j) = 0
        Next j
        k = k + 1
        If k > UBound(arr, 1) Then Exit Do
    Loop While arr(k, 1) = i
End If
Next i
' выгрузка результата
With Worksheets("res") ' res - это имя листа то имя листа с результатом
    .Cells.Clear
    lr = 1
    .Columns(1).NumberFormat = "@"
    MsgBox "Начата выгрузка на лист res..."
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 1) To UBound(arr, 2)
            .Cells(lr + 1, j) = arr(i, j)
        Next j
        lr = lr + 1
    Next i
    MsgBox "Выгрузка закончена!"
End With
End Sub
Function count_arr(arr) As Object
Dim i, j, d As Object, c As Long
Set d = CreateObject("Scripting.Dictionary")
c = 1
For i = 1 To UBound(arr, 2)
    j = i - 1
    If arr(0, i) = arr(0, j) Then
        c = c + 1
    Else
        d.Add CStr(arr(0, j)), c
        c = 1
    End If
Next i
j = i - 1
d.Add arr(0, j), c
Set count_arr = d
End Function
Private Function linear_search(arr, i, what) As Long
Dim j
linear_search = -1
For j = LBound(arr, 1) To UBound(arr, 1)
    If arr(j, i) = what Then linear_search = j: Exit Function
Next j
End Function
Function select_(sheet_name) As Variant
Dim mySQL As String, myConnect As String, myRecord As Object
Dim oRange As Range, QT As QueryTable, res, lr As Long
Set myRecord = CreateObject("ADODB.Recordset")
lr = Worksheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row
Set oRange = Worksheets(sheet_name).Range("A3:D" & lr) ' задается диапазон значений: здесь диапазон = А3:D26 (lr = 26) lr - менять не нужно, только цифру поле А

myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=NO;"""
mySQL = "SELECT [F1], [F2], [F3], [F4] FROM [" & sheet_name & "$" & oRange.Address(0, 0) & "] ORDER BY [F1] "
myRecord.Open mySQL, myConnect
res = myRecord.getrows()
select_ = res
myRecord.Close
Set myRecord = Nothing
End Function
Private Function transpose_arr(arr) As Variant
    Dim i, j, res()
    
    ReDim res(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            res(j + 1, i + 1) = arr(i, j)
        Next j
    Next i
    transpose_arr = res
End Function


Изменено: artemkau88 - 24.11.2022 09:34:58
 
Цитата
написал:
Цитата
написал:
Каковы могут быть причины?  
нужно предварительно отсортировать и первую и вторую таблицу по первому столбцу. Это из - за функции подсчета значений.   Обновил файл и код в сообщении #8  
Цитата
написал:
тяжело ему сортировать по алфавиту такой большой массив
Можете подсказать максимальный объем строк в массиве? Спасибо!

P.S:
добавил в предыдущее сообщение файл Образец_3_merge_sort.xlsb, проверьте, быстрее ли работает? У меня на 50_000 строк достаточно быстро.

Этот макрос подразумевает, что данные в первой и второй таблице начинаются с 3 строки, как в примере (после шапки):
Код
    [URL=#]?[/URL]       1      For   i = 2   To   UBound(arr, 1) - 2   ' здесь вычитаются 2 строки шапки таблицы, т.к данные начинаются с 3 строки   
 
код всей процедуры из файла "Образец_3_merge_sort.xlsb":
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31  32  33  34  35  36  37  38  39  40  41  42  43  44  45  46  47  48  49  50  51  52  53  54  55  56  57  58  59  60  61  62  63  64  65  66  67  68  69  70  71  72  73  74  75  76  77  78  79  80  81  82  83  84  85  86  87  88  89  90  91  92  93  94  95  96  97  98  99  100  101  102  103  104  105  106  107  108  109  110  111  112  113  114  115  116  117  118  119  120  121  122  123  124  125  126  127  128  129  130  131  132  133  134  135  136  137  138  139  140  141  142  143  144  145  146  147  148  149  150  151  152  153  154  155  156  157  158  159  160  161  162  163  164  165  166  167  168  169  170  171  172  173  174  175  176  177  178  179      Sub   fill_table()    Dim   arr   As   Variant  , data_arr   As   Variant  , from   As   Object  , data   As   Object  , lr   As   Long    Dim   i   As   Variant  , j, k, t, q    q = Timer    With   Worksheets(  "куда"  )   ' куда - это имя листа          lr = .Cells(.Rows.Count, 1).  End  (xlUp).Row          arr = .Range(  "A3:A"   & lr)          Set   data = count_arr(recursive_merge_sort_2d_array(arr, 1))          arr = Cells(2, 1).CurrentRegion: arr = recursive_merge_sort_2d_array(arr, 1)    End   With       With   Worksheets(  "откуда"  )   ' откуда - это имя листа          lr = .Cells(.Rows.Count, 1).  End  (xlUp).Row          data_arr = .Range(  "A3:A"   & lr)          Set   from = count_arr(recursive_merge_sort_2d_array(data_arr, 1))          data_arr = .Cells(2, 1).CurrentRegion: data_arr = recursive_merge_sort_2d_array(data_arr, 1)    End   With    Debug.Print Timer - q    For   Each   i   In   data.keys()    If   Not   IsEmpty(data(i))   And   Not   IsEmpty(from(i))   Then    k = linear_search(arr, 1, i)    t = linear_search(data_arr, 1, i)          If   data(i) = from(i)   Then              Do                  For   j = 2   To   UBound(data_arr, 2)                      arr(k, j) = data_arr(t, j)                  Next   j                  k = k + 1                  t = t + 1                  If   k > UBound(arr, 1)   Then   Exit   Do              Loop   While   arr(k, 1) = i          ElseIf   data(i) > from(i)   Then              Do                  For   j = 2   To   UBound(data_arr, 2)                      arr(k, j) = data_arr(t, j)                  Next   j                  k = k + 1                  t = t + 1                  If   t > UBound(data_arr, 1)   Then   Exit   Do              Loop   While   data_arr(t, 1) = i              Do                  arr(k, 2) = 0                  arr(k, 3) = 0                  arr(k, 4) = 0                  k = k + 1                  If   k > UBound(arr, 1)   Then   Exit   Do              Loop   While   arr(k, 1) = i                       Else              Do                  For   j = 2   To   UBound(data_arr, 2)                      arr(k, j) = data_arr(t, j)                  Next   j                  k = k + 1                  t = t + 1                  If   k > UBound(arr, 1)   Then   Exit   Do              Loop   While   arr(k, 1) = i              k = k - 1              Do                  arr(k, 2) = arr(k, 2) &   ", "   & data_arr(t, 2)                  arr(k, 3) = arr(k, 3) &   ", "   & data_arr(t, 3)                  t = t + 1                  If   t > UBound(data_arr, 1)   Then   Exit   Do              Loop   While   data_arr(t, 1) = i              arr(k, 4) = data_arr(t - 1, 4)          End   If    Else          k = linear_search(arr, 1, i)          Do              For   j = 2   To   UBound(arr, 2)                  arr(k, j) = 0              Next   j              k = k + 1              If   k > UBound(arr, 1)   Then   Exit   Do          Loop   While   arr(k, 1) = i    End   If    Next   i    ' выгрузка результата    With   Worksheets(  "res"  )   ' res - это имя листа то имя листа с результатом          .Cells.Clear          .Columns(1).NumberFormat =   "@"          lr = 1          MsgBox   "Начата выгрузка данных на лист res, подождите....."          For   i = 2   To   UBound(arr, 1) - 2   ' здесь вычитаются 2 строки шапки таблицы, т.к данные начинаются с 3 строки              For   j = LBound(arr, 2)   To   UBound(arr, 2)                  .Cells(lr + 1, j) = arr(i, j)              Next   j              lr = lr + 1          Next   i          MsgBox   "Выгрузка данных завершена!"    End   With    End   Sub    Private   Function   count_arr(arr)   As   Object    Dim   i, j, d   As   Object  , c   As   Long    Set   d = CreateObject(  "Scripting.Dictionary"  )    c = 1    For   i = 2   To   UBound(arr, 1)          j = i - 1          If   arr(i, 1) = arr(j, 1)   Then              c = c + 1          Else              d.Add   CStr  (arr(j, 1)), c              c = 1          End   If    Next   i    j = i - 1    d.Add arr(j, 1), c    Set   count_arr = d    End   Function    Private   Function   linear_search(arr, i, what)   As   Long    Dim   j    linear_search = -1    For   j = LBound(arr, 1)   To   UBound(arr, 1)          If   arr(j, i) = what   Then   linear_search = j:   Exit   Function    Next   j    End   Function    Private   Function   merge(a, b, colToSort   As   Long  )   As   Variant          Dim   arr(), p, i   As   Long  , j   As   Long  , k   As   Long          p = UBound(a, 1) + UBound(b, 1)          ReDim   arr(1   To   p, 1   To   UBound(a, 2)): i = 1: j = 1          For   k = 1   To   p              If   i > UBound(a, 1)   Then                  For   d = 1   To   UBound(b, 2)                      arr(k, d) =   CStr  (b(j, d))                  Next   d                      j = j + 1              ElseIf   j > UBound(b, 1)   Then                  For   d = 1   To   UBound(a, 2)                      arr(k, d) =   CStr  (a(i, d))                  Next   d                  i = i + 1              Else                  If   a(i, colToSort) < b(j, colToSort)   Then                      For   d = 1   To   UBound(a, 2)                          arr(k, d) =   CStr  (a(i, d))                      Next   d                      i = i + 1                  Else                      For   d = 1   To   UBound(b, 2)                          arr(k, d) =   CStr  (b(j, d))                      Next   d                      j = j + 1                  End   If              End   If          Next   k          merge = arr    End   Function    Private   Function   recursive_merge_sort_2d_array(arr, colToSort   As   Long  )   As   Variant          Dim   q   As   Long  , k   As   Long  , j   As   Long          Dim   a(), b()          Dim   d   As   Long          If   UBound(arr, 1) > 1   Then              If   UBound(arr)   Mod   2 = 0   Then                  q = Int(UBound(arr) / 2)                  ReDim   a(1   To   q, 1   To   UBound(arr, 2)):   ReDim   b(1   To   q, 1   To   UBound(arr, 2))              Else                  q = Int(UBound(arr) / 2)                  ReDim   a(1   To   q, 1   To   UBound(arr, 2)):   ReDim   b(1   To   q + 1, 1   To   UBound(arr, 2))              End   If              k = 1: j = 1              For   i = LBound(arr, 1)   To   UBound(arr, 1)                  If   i <= q   Then                      For   d = 1   To   UBound(arr, 2)                          a(j, d) =   CStr  (arr(i, d))                      Next   d                          j = j + 1                  Else                      For   d = 1   To   UBound(arr, 2)                          b(k, d) =   CStr  (arr(i, d))                      Next   d                      k = k + 1                  End   If              Next   i              a = recursive_merge_sort_2d_array(a, colToSort)              b = recursive_merge_sort_2d_array(b, colToSort)              arr = merge(a, b, colToSort)          End   If          recursive_merge_sort_2d_array = arr    End   Function   
 
Добрый вечер! К сожалению, ошибка возникает одна и та же при запуске любого из предложенных вариантов. Может ли быть проблема в том, что сортировка по номеру квартиры, которая находится в конце адреса, сортируется не по всему номеру квартиры, а по ее первым цифрам, то есть квартира с номером 14 будет стоять за 108 квартирой? Количество строк 45 000.
 
Анастасия, добрый вечер! Во вложении файл. Тестировал на 50_000 строк. Когда выскочит сообщение о выгрузке на лист, нажать "Ок" и ждать сообщения об окончании выгрузки. Результат - на листе "res". Макрос НЕ ТРЕБУЕТ предварительной сортировки по 1 столбцу в обоих таблицах. Результат на листе  "res" будет отсортирован. Обновил  код, нашел ошибку
Попробуйте этот код:
Код
Sub fill_table()
Dim arr As Variant, data_arr As Variant, from, data, lr As Long
Dim i, j, k, t, tmp, f, q
With Worksheets("куда") ' куда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = select_(.Name)
    data = count_arr(.Name)
    arr = transpose_arr(arr)
End With

With Worksheets("откуда") ' откуда - это имя листа
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    data_arr = select_(.Name)
    from = count_arr(.Name)
    data_arr = transpose_arr(data_arr)
End With
For i = LBound(data, 2) To UBound(data, 2)
tmp = data(0, i)
k = linear_search(arr, 1, tmp)
t = linear_search(data_arr, 1, tmp)
f = linear_search_item(data, 0, tmp)
q = linear_search_item(from, 0, tmp)
If k <> -1 And t <> -1 Then

    If data(1, f) = from(1, q) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = tmp
    ElseIf data(1, f) > from(1, q) Then
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = tmp
        Do
            arr(k, 2) = 0
            arr(k, 3) = 0
            arr(k, 4) = 0
            k = k + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = tmp
        
    Else
        Do
            For j = 2 To UBound(data_arr, 2)
                arr(k, j) = data_arr(t, j)
            Next j
            k = k + 1
            t = t + 1
            If k > UBound(arr, 1) Then Exit Do
        Loop While arr(k, 1) = tmp
        k = k - 1
        Do
            arr(k, 2) = arr(k, 2) & ", " & data_arr(t, 2)
            arr(k, 3) = arr(k, 3) & ", " & data_arr(t, 3)
            t = t + 1
            If t > UBound(data_arr, 1) Then Exit Do
        Loop While data_arr(t, 1) = tmp
        arr(k, 4) = data_arr(t - 1, 4)
    End If
Else
    k = linear_search(arr, 1, tmp)
    Do
        For j = 2 To UBound(arr, 2)
            arr(k, j) = 0
        Next j
        k = k + 1
        If k > UBound(arr, 1) Then Exit Do
    Loop While arr(k, 1) = tmp
End If
Next i
' выгрузка результата
With Worksheets("res") ' res - это имя листа то имя листа с результатом
    .Cells.Clear
    lr = 1
    .Columns(1).NumberFormat = "@"
    MsgBox "Начата выгрузка на лист res..."
    t = Timer
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 1) To UBound(arr, 2)
            .Cells(lr + 1, j) = arr(i, j)
        Next j
        lr = lr + 1
    Next i
    MsgBox "Выгрузка закончена за " & (Timer - t) & "s"
End With
End Sub
Function count_arr(sheet_name) As Variant
Dim mySQL As String, myConnect As String, myRecord As Object
Dim oRange As Range, QT As QueryTable, res, lr As Long
Set myRecord = CreateObject("ADODB.Recordset")
lr = Worksheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row
Set oRange = Worksheets(sheet_name).Range("A3:D" & lr) ' задается диапазон значений: здесь диапазон = А3:D26 (lr = 26) lr - менять не нужно, только цифру поле А

myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=NO;"""
mySQL = "SELECT [F1], COUNT([F1]) FROM [" & sheet_name & "$" & oRange.Address(0, 0) & "] GROUP BY [F1] ORDER BY [F1] "
myRecord.Open mySQL, myConnect
res = myRecord.getrows()
myRecord.Close
Set myRecord = Nothing
count_arr = res
End Function
Private Function linear_search(arr, i, what) As Long
Dim j
linear_search = -1
For j = LBound(arr, 1) To UBound(arr, 1)
    If arr(j, i) = what Then linear_search = j: Exit Function
Next j
End Function
Private Function linear_search_item(arr, i, what) As Long
Dim j
linear_search_item = -1
For j = LBound(arr, 2) To UBound(arr, 2)
    If arr(i, j) = what Then linear_search_item = j: Exit Function
Next j
End Function
Function select_(sheet_name) As Variant
Dim mySQL As String, myConnect As String, myRecord As Object
Dim oRange As Range, QT As QueryTable, res, lr As Long
Set myRecord = CreateObject("ADODB.Recordset")
lr = Worksheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row
Set oRange = Worksheets(sheet_name).Range("A3:D" & lr) ' задается диапазон значений: здесь диапазон = А3:D26 (lr = 26) lr - менять не нужно, только цифру поле А

myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source =" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=NO;"""
mySQL = "SELECT [F1], [F2], [F3], [F4] FROM [" & sheet_name & "$" & oRange.Address(0, 0) & "] ORDER BY [F1] "
myRecord.Open mySQL, myConnect
res = myRecord.getrows()
select_ = res
myRecord.Close
Set myRecord = Nothing
End Function
Private Function transpose_arr(arr) As Variant
    Dim i, j, res()
    
    ReDim res(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
    
    For i = LBound(arr, 1) To UBound(arr, 1)
        For j = LBound(arr, 2) To UBound(arr, 2)
            res(j + 1, i + 1) = arr(i, j)
        Next j
    Next i
    transpose_arr = res
End Function

Изменено: artemkau88 - 24.11.2022 17:29:00
 
artemkau88, я справилась! Предполагаю, что макросу важно, заглавная или прописная буква написана в адресе. В таблице "откуда" один адрес, например, Нахимовский проспект, может быть написан как Нахимовский Проспект, а номер дома 3б может быть написан как 3Б. Это мое предположение. При этом функция ВПР на это внимания не обращает. Я подтянула этой функцией адреса в таблицу "откуда" из таблицы "куда", заменила все адреса найденными, и макрос сработал! Я использовала Ваш пример Образец_2.xlsb.   От всей души благодарю Вас за большую помощь!!
 
Анастасия, рад за Вас! :)

Анастасия, добавил в код игнорирование регистра. Проверьте.
P.S.
но адреса, например Москва, Нахимовский проспект 3б != Нахимовский проспект 3б (то есть это разные адреса).
В то же время Нахимовский Проспект 3Б == нахимовский проспект 3б (это одинаковые адреса).
Макрос работает по точному совпадению. Поэтому это важно.
Так же обновил файл Образец_2.xlsb в сообщении выше, обнаружил ошибку / опечатку в коде
Спасибо!
Изменено: artemkau88 - 26.11.2022 09:50:34
Страницы: 1
Наверх