перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
artemkau88, я справилась! Предполагаю, что макросу важно, заглавная или прописная буква написана в адресе. В таблице "откуда" один адрес, например, Нахимовский проспект, может быть написан как Нахимовский Проспект, а номер дома 3б может быть написан как 3Б. Это мое предположение. При этом функция ВПР на это внимания не обращает. Я подтянула этой функцией адреса в таблицу "откуда" из таблицы "куда", заменила все адреса найденными, и макрос сработал! Я использовала Ваш пример Образец_2.xlsb. От всей души благодарю Вас за большую помощь!!
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
нужно предварительно отсортировать и первую и вторую таблицу по первому столбцу. Это из - за функции подсчета значений. Обновил файл и код в сообщении #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.
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
artemkau88, спасибо, что предупредили про сортировку. Переделаю ))))) второй вариант макроса сильно затормозил работу компьютера - тяжело ему сортировать по алфавиту такой большой массив. Но сохраню для меньших списков, спасибо!! А вот первый при внесении 45 000 строк лицевых счетов выдает вот такую ошибку: "This key is already associated with an element of this collection". При этом, когда я сокращаю список, допустим, до 500 строк - работает. Каковы могут быть причины?
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
artemkau88, добрый день! Могу я уточнить такой момент: если мне необходимо будет подтягивать данные не по текстовому полю (как по адресу), а по лицевому счету, например, надо ли менять код макроса? Я попробовала в колонку "адрес" вбить лицевые счета, которые состоят из 10 цифр, но формат ячеек при этом у них был текстовый, и макрос не сработал.
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
К сожалению, на моей таблице срабатывает только первый вариант макроса. Прикрепить таблицу не могу - слишком много весит Уточню, что я не сильна в макросах, возможно, проблема в типе файла, хотя я его сохранила как "с поддержкой макросов".
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
МатросНаЗебре, я разобралась, все получилось на примере. Однако, при запуске макроса программа пожаловалась 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). Предполагаю, что при соединении лишних строк из таблицы "откуда" в колонке "назначение платежа" получается слишком длинное значение. Можно ли упростить эту задачу для колонки "назначение платежа", чтобы при нахождении лишних строк для одного адреса в таблице "откуда" в эту колонку возвращалось лишь одно значение в таблицу "куда" (любое из найденных лишних строк).
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
Пожалуйста, помогите автоматизировать процесс переноса данных из одной таблицы в другую. Есть исходная таблица, "откуда" надо перенести данные, есть таблица, "куда" надо перенести. Поиск производится по полю "адрес". При этом количество строк для одного и того же адреса в обеих таблицах разное, а так же есть адреса, которые присутствуют в одной и отсутствуют в другой. В таблице "куда" количество строк изменять нельзя.
Если в таблице "откуда" количество строк для одного адреса больше, чем в таблице "куда", то данные по номеру и дате платежа для лишних строк переносятся через "запятую с пробелом" в последнюю найденную строку данного адреса таблицы "куда", а назначение платежа берется из последней найденной строки.
Если наоборот, в таблице "откуда" количество строк для одного адреса меньше, чем в таблице "куда", то пустые ячейки заполняются нолями.
В случае полного соответствия количества строк по одному адресу в обеих таблицах данные переносятся как есть.
Для наглядности пример во вложении.
Заранее благодарю за любой совет. Пока перенесла данные по полному соответствию строк, а так же при разнице в 1 строку. Остальные случаи занимают слишком много времени. А строк надо перенести 15 000
Mershik написал: На каждом листе изначально в шаблоне я бы сделал заранее формулу в какой-то ячейке например D1
Mershik, пользователь Тимофеев предложил на каждом листе изначально прописать заранее формулу, однако файл присылает сторонняя организация, а листов более 300... Или я не верно поняла его идею...
[URL=#]?[/URL] 1 2 3 4 5 6 7 8 9 10 Sub mrshkei() Dim sh As Worksheet, cell As Range For Each sh In Worksheets Set cell = sh.Columns(1).Find(What:= "итого" , LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:= False , SearchFormat:= False ) k = k + cell.Offset(0, 1).Value Next sh MsgBox "Сумма составила: " & k End Sub
Спасибо огромное! Попробую его прописать - надо вспомнить азы написания макросов, не сообразила, куда кликать, чтобы прописать тело макроса.
Сергей написал: еще вариант в столбце F добавляете названия листов они автоматом подтягиваются в формулу
Спасибо большое за Ваш вариант - отлично работает. Но теперь возникли трудности с получением списка наименований листов. Не удалось корректно установить надстройку ЁXCEL, с помощью которой можно получить этот список. Установила каким-то образом PLEX, однако в менеджере листов не получается скопировать список наименований. В итоге через функцию "объединение" собрала все таблицы на один лист и по фильтру "итого" посчитала сумму.
Тимофеев, к сожалению, этого невозможно сделать - данные присылает другая организация, которую наши трудности не интересуют. А так, согласна, было бы проще. Остается мучиться с тем, что есть
Добрый день! Помогите, пожалуйста, сложить итоги с большого количества листов. В каждом листе - разное количество строк. Наименование итоговой строки на каждом листе отличается календарным месяцем. При необходимости, есть возможность создать список со всеми возможными наименованиями строк (если это поможет). Буду очень благодарна, если поможете автоматизировать этот процесс (листов более 300 штук ) Прикладываю пример такого файла. Работаю на Office 2010.