Добрый день! Помогите пожалуйста, кто чем может Такой вопрос: каким образом с помощью макроса можно объединить данные, чтобы при дублировании данных в столбце "Табельный номер" в остальных ("Филиал", "Группа компаний","Заемщик","Тип бизнеса") - удалялись дубли. А столбцы "Кредит" и "Гарантия" суммировались в один столбец, то есть получался некий Итог (кредит + гарантия). Пример прикладываю. Так же прикладываю файл, который нашла на форуме. Но у меня никак не получается его скорректировать под себя,но по функциям он похож. Тоже при дублировании складывает единую сумму. Всем заранее огромное спасибо за любые ответы!
Макрос в стандартный модуль, запускать при активном листе "что есть"
Код
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
Hugo, Спасибо огромнейшее за ответ! Тоже думала так сделать, через удаление дублей, но хотелось бы макросом данную функцию реализовать! Большое спасибо за ещё один способ!
Если данных много - то код Кузмича в строках 11 и 12 теоретически может накосячить, т.к. производитель не гарантирует соответствие этих пар по позиции в словаре, надёжнее потрудиться и наполнить циклом двумерный массив, извлекая для каждого ключа его значение/итем.
Hugo, ох, к сожалению, у меня большой объем данных, более 10 тысяч строк будет, наверное. Вот тоже думаю, как среагирует макрос на такой объем. я попробую его на большом объеме информации. Посмотрю, как сработает. Но так как табельный номер каждый раз будет разный, то поэтому хотелось более оптимизировать задачу.
Вообще у Application.Transpose есть какие-то ограничения на количество переворачиваемых строк, но думаю 10000 последние версии тянут. Да и то, о чём я писал выше - пока никто достоверно не наблюдал. Но если вдруг эти ошибки встретятся Вам - то я предупредил И как обойти - написал, но может и тут кто код чуть дошлифует.
Kuzmich, а можно у Вас пожалуйста спросить. Может подскажите, есть ли способ как-то сделать группировку по дате, например, если дата начала договора, то брать раннюю дату, а если дата окончания договора, то брать позднюю. Имею в виду чтобы сортировка была при использования Вашего макроса. Я приложила пример в файлике.
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, большущее Вам спасибо! Очень выручили! Буду тестировать на большом объеме, но уже глянула на этом примере и это как и в тот раз прям супер!))))
Kuzmich, прошу прощение( В следующий раз заранее предупрежу!
Подскажите пожалуйста, а если Ваш макрос использовать на большом объеме строк и при срабатывании выдает такую ошибку: "object variable or with block variable not set". В итоге объединяет около 22 строк, а остальные строки лишь столбцы "Табельный номер" и "Итог (кредит + гарантия)",оставляя другие столбцы пустыми. В чем может быть проблема?
Kuzmich, вроде с ошибкой разобралась, возникала из-за текстового формата в табельном номере. После корректировки во всем столбце "Табельный номер" формата значений на числовой всё заработало!)