Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » Анастасия Тюрькова
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
25.11.2022 09:08:56
artemkau88, я справилась! Предполагаю, что макросу важно, заглавная или прописная буква написана в адресе. В таблице "откуда" один адрес, например, Нахимовский проспект, может быть написан как Нахимовский Проспект, а номер дома 3б может быть написан как 3Б. Это мое предположение. При этом функция ВПР на это внимания не обращает. Я подтянула этой функцией адреса в таблицу "откуда" из таблицы "куда", заменила все адреса найденными, и макрос сработал! Я использовала Ваш пример Образец_2.xlsb.   От всей души благодарю Вас за большую помощь!!
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
24.11.2022 16:44:30
Цитата
написал:
Цитата
написал:
Каковы могут быть причины?  
нужно предварительно отсортировать и первую и вторую таблицу по первому столбцу. Это из - за функции подсчета значений.   Обновил файл и код в сообщении #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 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
23.11.2022 15:00:09
artemkau88, спасибо, что предупредили про сортировку. Переделаю ))))) второй вариант макроса сильно затормозил работу компьютера - тяжело ему сортировать по алфавиту такой большой массив. Но сохраню для меньших списков, спасибо!! А вот первый при внесении 45 000 строк лицевых счетов выдает вот такую ошибку: "This key is already associated with an element of this collection". При этом, когда я сокращаю список, допустим, до 500 строк - работает. Каковы могут быть причины?  
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
23.11.2022 10:04:48
artemkau88, добрый день! Могу я уточнить такой момент: если мне необходимо будет подтягивать данные не по текстовому полю (как по адресу), а по лицевому счету, например, надо ли менять код макроса? Я попробовала в колонку "адрес" вбить лицевые счета, которые состоят из 10 цифр, но формат ячеек при этом у них был текстовый, и макрос не сработал.
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
22.11.2022 15:45:42
artemkau88, спасибо большое, все сработало! Вероятно, я не правильно записывала макрос с кодом выше. Очень выручили!
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
22.11.2022 11:15:07
К сожалению, на моей таблице срабатывает только первый вариант макроса. Прикрепить таблицу не могу - слишком много весит :( Уточню, что я не сильна в макросах, возможно, проблема в типе файла, хотя я его сохранила как "с поддержкой макросов".  
Изменено: Анастасия Тюрькова - 22.11.2022 11:21:00
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
22.11.2022 09:32:34
МатросНаЗебре, я разобралась, все получилось на примере. Однако, при запуске макроса программа пожаловалась 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
 
Перейти    
перенос данных из одной таблицы в другую при разном количестве совпадений, 2 таблицы содержат разное количество строк для одного и того же параметра. Необходимо перенести данные из одной таблицы в другую, не меняя количество строк во второй.
 
#
21.11.2022 15:56:22
Всем добрый день!

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

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

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

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

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


Заранее благодарю за любой совет. Пока перенесла данные по полному соответствию строк, а так же при разнице в 1 строку. Остальные случаи занимают слишком много времени. А строк надо перенести 15 000 :(
Изменено: Анастасия Тюрькова - 21.11.2022 16:13:02
 
Перейти    
Сложение итогов с большого количества листов с разным названием итоговой строки
 
#
02.06.2021 15:14:03
Цитата
Mershik написал:
На каждом листе изначально в шаблоне я бы сделал заранее формулу в какой-то ячейке например D1
Mershik, пользователь Тимофеев предложил на каждом листе изначально прописать заранее формулу, однако файл присылает сторонняя организация, а листов более 300... Или я не верно поняла его идею...
 
Перейти    
Сложение итогов с большого количества листов с разным названием итоговой строки
 
#
02.06.2021 15:04:30
Цитата
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  
 
Спасибо огромное! Попробую его прописать - надо вспомнить азы написания макросов, не сообразила, куда кликать, чтобы прописать тело макроса.
 
Перейти    
Сложение итогов с большого количества листов с разным названием итоговой строки
 
#
02.06.2021 15:00:12
Цитата
Сергей написал:
еще вариант в столбце F добавляете названия листов они автоматом подтягиваются в формулу
Спасибо большое за Ваш вариант - отлично работает. Но теперь возникли трудности с получением списка наименований листов. Не удалось корректно установить надстройку ЁXCEL, с помощью которой можно получить этот список. Установила каким-то образом PLEX, однако в менеджере листов не получается скопировать список наименований. В итоге через функцию "объединение" собрала все таблицы на один лист и по фильтру "итого" посчитала сумму.  
 
Перейти    
Сложение итогов с большого количества листов с разным названием итоговой строки
 
#
02.06.2021 14:52:09
Тимофеев, к сожалению, этого невозможно сделать - данные присылает другая организация, которую наши трудности не интересуют. А так, согласна, было бы проще. Остается мучиться с тем, что есть  :cry:  
Изменено: vikttur - 02.06.2021 18:37:25
 
Перейти    
Сложение итогов с большого количества листов с разным названием итоговой строки
 
#
02.06.2021 09:20:37
Добрый день! Помогите, пожалуйста, сложить итоги с большого количества листов. В каждом листе - разное количество строк. Наименование итоговой строки на каждом листе отличается календарным месяцем. При необходимости, есть возможность создать список со всеми возможными наименованиями строк (если это поможет). Буду очень благодарна, если поможете автоматизировать этот процесс (листов более 300 штук  :cry: ) Прикладываю пример такого файла. Работаю на Office 2010.
Изменено: vikttur - 02.06.2021 09:47:01
 
Перейти    
Страницы: 1
Наверх