перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
Пожалуйста, помогите автоматизировать процесс переноса данных из одной таблицы в другую. Есть исходная таблица, "откуда" надо перенести данные, есть таблица, "куда" надо перенести. Поиск производится по полю "адрес". При этом количество строк для одного и того же адреса в обеих таблицах разное, а так же есть адреса, которые присутствуют в одной и отсутствуют в другой. В таблице "куда" количество строк изменять нельзя.
Если в таблице "откуда" количество строк для одного адреса больше, чем в таблице "куда", то данные по номеру и дате платежа для лишних строк переносятся через "запятую с пробелом" в последнюю найденную строку данного адреса таблицы "куда", а назначение платежа берется из последней найденной строки.
Если наоборот, в таблице "откуда" количество строк для одного адреса меньше, чем в таблице "куда", то пустые ячейки заполняются нолями.
В случае полного соответствия количества строк по одному адресу в обеих таблицах данные переносятся как есть.
Для наглядности пример во вложении.
Заранее благодарю за любой совет. Пока перенесла данные по полному соответствию строк, а так же при разнице в 1 строку. Остальные случаи занимают слишком много времени. А строк надо перенести 15 000
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
МатросНаЗебре, я разобралась, все получилось на примере. Однако, при запуске макроса программа пожаловалась 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). Предполагаю, что при соединении лишних строк из таблицы "откуда" в колонке "назначение платежа" получается слишком длинное значение. Можно ли упростить эту задачу для колонки "назначение платежа", чтобы при нахождении лишних строк для одного адреса в таблице "откуда" в эту колонку возвращалось лишь одно значение в таблицу "куда" (любое из найденных лишних строк).
В этом варианте не дописывается "назначение платежа". Предположу, что дело было не в длине строки, скорее всего, закралось какое-то ошибочное значение.
Код
'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
К сожалению, на моей таблице срабатывает только первый вариант макроса. Прикрепить таблицу не могу - слишком много весит Уточню, что я не сильна в макросах, возможно, проблема в типе файла, хотя я его сохранила как "с поддержкой макросов".
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, добрый день! Могу я уточнить такой момент: если мне необходимо будет подтягивать данные не по текстовому полю (как по адресу), а по лицевому счету, например, надо ли менять код макроса? Я попробовала в колонку "адрес" вбить лицевые счета, которые состоят из 10 цифр, но формат ячеек при этом у них был текстовый, и макрос не сработал.
Анастасия, добрый день! У меня корректно отработал при формате текстовых значений в первом столбце 2-х таблиц, даже с нулями в начале и с цифрами тоже корректно (вбивал 10-ти значные цифры). Результат смотрите на листе res? Данные лицевых счетов находятся в первом столбце в обоих таблицах, как в примере?
P.S. забыл написать важный момент: данные в обоих таблицах должны быть отсортированы в порядке возрастания по первому столбцу ( с адресом (лицевым счетом)) Обновил файл с макросом в сообщении #8
Либо без предварительной сортировки первых столбцов (сортировка происходит в макросе). Результат - отсортированный по первому столбцу заполненный массив
Добавил вариант с сортировкой слиянием: "Образец_3_merge_sort.xlsb" (также добавил уведомлялки с началом и окончанием выгрузки на лист "res")
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
Добавил еще вариант без предварительной сортировки. Сортируется запросом 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
нужно предварительно отсортировать и первую и вторую таблицу по первому столбцу. Это из - за функции подсчета значений. Обновил файл и код в сообщении #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, я справилась! Предполагаю, что макросу важно, заглавная или прописная буква написана в адресе. В таблице "откуда" один адрес, например, Нахимовский проспект, может быть написан как Нахимовский Проспект, а номер дома 3б может быть написан как 3Б. Это мое предположение. При этом функция ВПР на это внимания не обращает. Я подтянула этой функцией адреса в таблицу "откуда" из таблицы "куда", заменила все адреса найденными, и макрос сработал! Я использовала Ваш пример Образец_2.xlsb. От всей души благодарю Вас за большую помощь!!
Анастасия, добавил в код игнорирование регистра. Проверьте. P.S. но адреса, например Москва, Нахимовский проспект 3б != Нахимовский проспект 3б (то есть это разные адреса). В то же время Нахимовский Проспект 3Б == нахимовский проспект 3б (это одинаковые адреса). Макрос работает по точному совпадению. Поэтому это важно. Так же обновил файл Образец_2.xlsb в сообщении выше, обнаружил ошибку / опечатку в коде Спасибо!