Страницы: 1
RSS
Из строк с одинаковым значение - сделать одну, и сложить сумму с определенного столбца
 
Добрый день, искал в интернете подобное, но всё не то, возможно даже не знаю как правильно формулировать вопрос

Есть папка с файлами excel, ~10.000 файлов, в каждом по 150 строк, в строках повторяются названия - для каждого своя сумма, нужно сделать, чтобы повторений не было и каждую сумму сложить в единую, на словах ничего не понятно, поэтому делаю пример и прикладываю файл с примером (1 лист - исходная база, 2 лист - то, что должно получится)

Исходная база:
ДатаДокДатаСостНаимНаимУслугОбщСумУсл
10.04.202131.12.2019Ourav961874287Груша4626;54
10.04.202131.12.2019Ourav961874287Яблоко102672;68
10.04.202131.12.2019Ourav961874287Арбуз23801;47
10.04.202131.12.2019Bylar710597001Апельсин27191;76
10.04.202131.12.2019Bylar710597001Банан1000
10.04.202131.12.2019Kiandlay374495991Груша200
10.04.202131.12.2019Kiandlay374495991Огурец733;3
10.04.202131.12.2019Kiandlay374495991Помидор170
10.04.202131.12.2019Kiandlay374495991Груша96;7
то, что должно получится:
ДатаДокДатаСостНаимНаимУслугОбщСумУсл
10.04.202131.12.2019Ourav961874287Общее131100;69
10.04.202131.12.2019Bylar710597001Общее28191;76
10.04.202131.12.2019Kiandlay374495991Общее1200
Подскажите, как можно это сделать, может быть с помощью макросов vba, или хотя бы намек, буду очень признателен!
 
а чем сводная не подходит? или можно в PQ
Изменено: Vik_tor - 20.07.2021 20:58:58
 
Нужно посчитать не сумму всех полей, а на примере первых трёх строк: есть наименование "Ourav", у него есть "груша, яблоко, арбуз", каждое со своей суммой, и нужно сделать из трёх строк одну с общей суммой этих товаров ("наимусл"), и так с каждой
 
Код
Sub mrshkei()
With Sheets(1)
Dim arr, arr2, arr3, i As Long, n As Long, lr As Long, k As Long, col As New Collection
lr = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:F" & lr)
For i = LBound(arr) To UBound(arr)
    On Error Resume Next
    col.Add arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "Общее", arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "Общее" & "//"
Next i
ReDim arr2(1 To col.Count, 1 To 6)
For i = 1 To col.Count
    arr3 = Split(col(i), "//")
    For n = LBound(arr3) To UBound(arr3)
        arr2(i, n + 1) = arr3(n)
    Next n
    arr2(i, 6) = Application.WorksheetFunction.SumIfs(.Columns(6), _
                 .Columns(1), arr3(0), _
                 .Columns(2), arr3(1), _
                 .Columns(3), arr3(2), _
                 .Columns(4), arr3(3))
Next i
End With
Sheets(2).Range("A15").Resize(UBound(arr2), 6) = arr2
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Спасибо большое за макрос, немного модернизировал его, теперь он парсит все файлы в папке, удаляет не нужные столбцы, сохраняет итд, но возникла проблема с массивами, при сохранении файлов - вставляются прошлые строки, пример:

Первый файл:
Скрытый текст
2 файл:
Скрытый текст
3 файл:
Скрытый текст
Было бы очень даже здорово, если данные со всех файлов собрались в один большой, но ОбщСум пропадает, и ставит нули
Хотелось бы узнать, как можно избежать копирование данных с прошлых файлов или наоборот, чтобы файлы обьеденялись, но в ОбщСум стояли не нули

3 примера файлов выкладываю также

Макрос:
Код
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String, arr, arr2, arr3, i As Long, n As Long, lr As Long, k As Long, col As New Collection
    Dim wb As Workbook
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        'действия с файлом

        With Sheets(1)
        Columns(6).Delete
        Columns(6).Delete
        Columns(6).Delete
lr = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:F" & lr)
For i = LBound(arr) To UBound(arr)
    On Error Resume Next
    col.Add arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "?????", arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "?????" & "//"
Next i
ReDim arr2(1 To col.Count, 1 To 6)
For i = 1 To col.Count
    arr3 = Split(col(i), "//")
    For n = LBound(arr3) To UBound(arr3)
        arr2(i, n + 1) = arr3(n)
    Next n
    arr2(i, 6) = Application.WorksheetFunction.SumIfs(.Columns(6), _
                 .Columns(1), arr3(0), _
                 .Columns(2), arr3(1), _
                 .Columns(3), arr3(2), _
                 .Columns(4), arr3(3))
Next i
End With
ActiveSheet.UsedRange.Offset(1).Clear
Sheets(1).Range("A2").Resize(UBound(arr2), 6) = arr2
Columns(5).Delete
Columns(3).Delete

        'Закрываем книгу с сохранением изменений
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub

Изменено: vikttur - 21.07.2021 23:29:03
 
Для коллекции прикладываю ссылку на статью со сходной по смыслу задачей
Сборка таблиц с разными шапками из нескольких книг
Возможно, Вам покажутся интересными описанные в ней идеи.
Страницы: 1
Наверх