Страницы: 1
RSS
Объединение данных с удалением дублей с помощью макроса
 
Добрый день!
Помогите пожалуйста, кто чем может
Такой вопрос: каким образом с помощью макроса можно объединить данные, чтобы при дублировании данных в столбце "Табельный номер" в остальных ("Филиал", "Группа компаний","Заемщик","Тип бизнеса") - удалялись дубли.
А столбцы "Кредит" и "Гарантия" суммировались в один столбец, то есть получался некий Итог (кредит + гарантия).
Пример прикладываю.
Так же прикладываю файл, который нашла на форуме. Но у меня никак не получается его скорректировать под себя,но по функциям он похож. Тоже при дублировании складывает единую сумму.
Всем заранее огромное спасибо за любые ответы! :oops:
Изменено: Melancholia - 09.11.2019 14:29:08
 
Макрос в стандартный модуль, запускать при активном листе "что есть"
Код
Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
  Next
End With
End Sub
 
Ну или скопировать на новый лист номера, удалить дубли, затем применить UDF из копилки и стандартную суммесли
В примере слева таблица с формулами, справа изначальный пример (кода в файле нет, берите в копилке https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=2&TID=10&TITLE_SEO=10 )
Изменено: Hugo - 09.11.2019 16:52:48
 
Kuzmich, огоооо, то, что нужно. Ещё тестирую, но это прям то, что нужно! Огромнейшее спасибо!!!! Срабатывает прямо супер! ;)  
 
Hugo, Спасибо огромнейшее за ответ! Тоже думала так сделать, через удаление дублей, но хотелось бы макросом данную функцию реализовать! Большое спасибо за ещё один способ! ;)  
 
Если данных много - то код Кузмича в строках 11 и 12 теоретически может накосячить, т.к. производитель не гарантирует соответствие этих пар по позиции в словаре, надёжнее потрудиться и наполнить циклом двумерный массив, извлекая для каждого ключа его значение/итем.
 
Hugo, ох, к сожалению, у меня большой объем данных, более 10 тысяч строк будет, наверное. Вот тоже думаю, как среагирует макрос на такой объем. я попробую его на большом объеме информации. Посмотрю, как сработает. Но так как табельный номер каждый раз будет разный, то поэтому хотелось более оптимизировать задачу.
 
Вообще у Application.Transpose есть какие-то ограничения на количество переворачиваемых строк, но думаю 10000 последние версии тянут.
Да и то, о чём я писал выше - пока никто достоверно не наблюдал. Но если вдруг эти ошибки встретятся Вам - то я предупредил :)
И как обойти  - написал, но может и тут кто код чуть дошлифует.
Изменено: Hugo - 09.11.2019 17:24:52
 
Kuzmich, а можно у Вас пожалуйста спросить. :oops:
Может подскажите, есть ли способ как-то сделать группировку по дате, например, если дата начала договора, то брать раннюю дату, а если дата окончания договора, то брать позднюю. Имею в виду чтобы сортировка была при использования Вашего макроса.
Я приложила пример в файлике.
 
Цитата
есть ли способ как-то сделать
Код
Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Dim FAdr As String
Dim FDate As Date
Dim EDate As Date
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row + 1).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
    FAdr = FoundNomer.Address
      FDate = Cells(FoundNomer.Row, "E")
      EDate = Cells(FoundNomer.Row, "F")
      Do
        Set FoundNomer = Columns(4).FindNext(FoundNomer)
        If Cells(FoundNomer.Row, "E") < FDate Then FDate = Cells(FoundNomer.Row, "E")
        If Cells(FoundNomer.Row, "F") > EDate Then EDate = Cells(FoundNomer.Row, "F")
      Loop While FoundNomer.Address <> FAdr
        .Cells(i, "E") = FDate
        .Cells(i, "F") = EDate
  Next
End With
End Sub
 
Kuzmich, большущее Вам спасибо! Очень выручили! Буду тестировать на большом объеме, но уже глянула на этом примере и это как и в тот раз прям супер!)))) :*  
 
О кроссе надо предупреждать http://www.excelworld.ru/forum/10-43370-1
 
Kuzmich, прошу прощение( В следующий раз заранее предупрежу!

Подскажите пожалуйста, а если Ваш макрос использовать на большом объеме строк и при срабатывании выдает такую ошибку:
"object variable or with block variable not set".
В итоге объединяет около 22 строк, а остальные строки лишь столбцы "Табельный номер" и "Итог (кредит + гарантия)",оставляя другие столбцы пустыми. В чем может быть проблема?
 
Kuzmich, вроде с ошибкой разобралась, возникала из-за текстового формата в табельном номере. После корректировки во всем столбце "Табельный номер" формата значений на числовой всё заработало!)
 
Цитата
Melancholia написал:
Помогите пожалуйста, кто чем может
М.б. обойдемся без макроса? :)
Сводная таблица тоже почти может почти всё :)
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
Страницы: 1
Наверх