Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Сводный отчёт из нескольких файлов
 
#1
25.12.2019 15:37:15
Здравствуйте уважаемые форумчане! Задачка не новая, но есть ньюансы:

В папке находятся примерно 200 файлов с отчётами.
Необходимо:
-в каждом файле снять фильтр по столбцу Е
-скопировать строки с данными начиная ниже 8 строки (включительно) (пустые строки не нужны)
Далее в итоговом отчёте:
-вставить скопированные строки в итоговый отчёт последовательно из каждого отчёта
-установить фильтр по столбцу Е по значению "+"
-скрыть столбец Е
-перейти в ячейку А1
-сохранить итоговый отчёт

Подскажите, пожалуйста, решение, как автоматизировать эти однотипные операции. :qstn:  
Изменено: Владимир Никифоров - 25.12.2019 15:40:59
 
 
 
#2
25.12.2019 15:55:31
Владимир Никифоров, вариант на PQ

Необходимо:
1) Поместить все файлы Отчёт1, Отчёт2 в папку "Отчеты".
2) Файл во вложении должен находится на 1 уровень выше.
3) Откройте файл, сохраните его и нажмите "Обновить все".
 
 
 
#3
25.12.2019 15:55:31
Я бы предложил один из 2-х вариантов:
1. Обратиться в раздел форума "Работа". Где Вам обязательно помогут за денюжку. (добрые люди уже помогли)
2. Попробовать самостоятельно разобраться с надстройкой Power Query, судя по описанию, в ней вполне реально всё сделать. https://www.planetaexcel.ru/techniques/24/2152/
Изменено: Wiss - 25.12.2019 15:59:42
Я не волшебник, я только учусь.
 
 
 
#4
25.12.2019 16:23:14
Код
Public first_file As Boolean
Sub Main()
    Application.ScreenUpdating = False
    
    Dim shSum As Worksheet:
    Set shSum = ThisWorkbook.Sheets(1)
    Job_sum_sheet1 shSum
    Job_folder shSum
    Job_sum_sheet2 shSum
    Application.ScreenUpdating = True
End Sub

Код
Sub Job_folder(shSum As Worksheet)
    Dim fso As Object: Set fso = CreateObject("Scripting.Filesystemobject")
    Dim f As Variant
    first_file = True
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        With f
            If fso.GetExtensionName(.Name) Like ("xls*") Then
                If Left(.Name, 2) <> "~$" Then
                    If .Name <> ThisWorkbook.Name Then
                        Application.StatusBar = .Name
                        Job_file f, shSum
                        Application.StatusBar = False
                    End If
                End If
            End If
        End With
        DoEvents
    Next
    Application.CutCopyMode = False
End Sub
Код
Sub Job_file(ByVal sFull As String, shSum As Worksheet)
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFull)
    Job_sheet wb.Sheets(1), shSum
    wb.Close False
End Sub
Код
Sub Job_sheet(sh As Worksheet, shSum As Worksheet)
    
    Dim rTo As Range
    With ThisWorkbook.Sheets(1)
'        If .Cells(1, 1).Value = "" Then
'            Set rTo = .Cells(1, 1)
'        Else
            Set rTo = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
'        End If
    End With
    
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(7, 1), .Cells(y, 5)).AutoFilter Field:=5
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("8:" & y).Copy rTo
        If first_file Then
            .Rows("8:" & y).Copy
            rTo.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            first_file = False
        End If
    End With
    Application.CutCopyMode = False
End Sub
Код
Sub Job_sum_sheet1(shSum As Worksheet)
    With shSum
        .Columns("A:E").Delete Shift:=xlToLeft
    End With
End Sub
Код
Sub Job_sum_sheet2(shSum As Worksheet)
    With shSum
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Then
                .Rows(y).Delete
            End If
        Next
        
        .Parent.Activate
        .Select
        .Cells(1, 1).Select
        .Range(.Cells(1, 1), .Cells(y, 5)).AutoFilter Field:=5, Criteria1:="+"
        .Columns("E:E").EntireColumn.Hidden = True
        
        Application.DisplayAlerts = False
        .Parent.Save
        Application.DisplayAlerts = True
    End With
End Sub
Изменено: МатросНаЗебре - 26.12.2019 12:41:55
 
 
 
#5
25.12.2019 23:36:19
МатросНаЗебре, появляется ошибка синтаксиса в первом макросе по этим строкам
Код
    Set shSum = ThisWorkbook.Sheets(1)    Job_sum_sheet1 shSum

    Job_sum_sheet2 shSum    Application.ScreenUpdating = True
 
 
 
#6
25.12.2019 23:50:32
Murderface_, Wiss, ,вариант на PQ попробовал, в принципе- получилось, но, непонятно, как сохранить исходное форматирование (шрифт, заливка и.т.п.). Заливка, к примеру, удобна для того, чтобы навскидку определить тип дефекта. Приложу 2 файла: первый-это то, что выдаёт PQ, второй то, что хотелось бы получить на выходе.
 
 
 
#7
26.12.2019 06:58:10
Цитата
Владимир Никифоров написал:
как сохранить исходное форматирование
Не уверен, что с помощью PQ можно его сохранить, скорее всего только с помощью VBA.
 
 
 
#8
26.12.2019 10:11:26
Цитата
Murderface_ написал:
Не уверен, что с помощью PQ можно
Тоже не уверен. Точнее, скорее почти уверен, что нельзя. PQ с данными работает, а не форматированиями. Это фактически БД. Вариант МатросНаЗебре, вроде бы с форматированием копирует.
Я не волшебник, я только учусь.
 
 
 
#9
26.12.2019 12:41:19
Код
Set shSum = ThisWorkbook.Sheets(1)
Job_sum_sheet1 shSum 

Job_sum_sheet2 shSum    
Application.ScreenUpdating = True
Эти строки должны выглядеть так. Потерялся разрыв строки при копировании на форум. Поправил и в исходном сообщении.
 
 
 
#10
26.12.2019 13:48:09
Цитата
Владимир Никифоров написал:
но, непонятно, как сохранить исходное
А вам не нужно исходное, вам нужно в принципе форматирование. Ваша задаче легко решается с помощью маленького справочника и УФ.
Можно и без справочника, но тогда надо будет правил побольше сделать - не принципиально.
Вот горшок пустой, он предмет простой...
 
 
 
#11
26.12.2019 15:25:28
МатросНаЗебре, макрос не заработал, увы. По этой строке:
Код
For y = UBound(a, 1) To 2 Step -1
 
 
 
#12
26.12.2019 15:31:23
Код
Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        If y = 1 Then
            ReDim a(1 To 1, 1 To 1)
            a(1, 1) = .Cells(y, 1).Value
        Else
            a = .Range(.Cells(1, 1), .Cells(y, 1))
        End If
        
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
 
 
 
#13
26.12.2019 15:36:58

Пока использую "полуавтоматическое" решение:

Код
Sub Копировать_ячейки()
' Сочетание клавиш: Ctrl+ч

     Range("A8:E100").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Трубопроводы межцеховые.xlsx").Activate ' текст в кавычках=имя файла сводного отчёта
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
   End Sub

Однако приходится последовательно открывать каждый фал и применять макрос. Подскажите, пожалуйста, как допилить макрос, чтобы сделать следующие шаги:

-1. Зайти в определённую папку

-2. Открыть файл

-3. Применить макрос

-4. Закрыть файл без сохранения

-5. Повторить пункты 1-4 для всех файлов в папке

Для облегчения задачи можно предварительно переименовать файлы (например Отчёт1, Отчёт2, Отчёт3 и.т.д.)

Изменено: Владимир Никифоров - 26.12.2019 15:52:07
 
 
 
#14
26.12.2019 15:51:35
Цитата
PooHkrd написал:
А вам не нужно исходное, вам нужно в принципе форматирование. Ваша задаче легко решается с помощью маленького справочника и УФ.Можно и без справочника, но тогда надо будет правил побольше сделать - не принципиально.
Решение на PQ, конечно, самое элегантное. Сейчас пришлось использовать VBA тупо потому, что внешний вид ранее оформленных отчётов и последующих должен быть одинаковым (от слова совсем :D ). А так, да, PQ - это отличный инструмент.
 
 
 
#15
26.12.2019 22:22:40
МатросНаЗебре,

Простите за глупый вопрос, куда вставить этот блок кода из сообщения №12?
Изменено: Владимир Никифоров - 26.12.2019 22:37:40
 
 
 
#16
27.12.2019 09:17:25
Вставьте, например, в конец модуля. И удалите существующую процедуру DeleteEmptyRow. От Sub DeleteEmptyRow(sh As Worksheet) до End Sub.
 
 
 
#17
27.12.2019 11:16:46
МатросНаЗебре,
Цитата
МатросНаЗебре написал:
Вставьте, например, в конец модуля. И удалите существующую процедуру DeleteEmptyRow. От Sub DeleteEmptyRow(sh As Worksheet) до End Sub.
Что-то я туплю. Не могу понять, куда именно вставить код.
Вот код из сообщения №4 целиком. Если не сложно поправьте, пожалуйста
Код
Public first_file As Boolean
Sub Main()
    Application.ScreenUpdating = False
     
    Dim shSum As Worksheet:
    Set shSum = ThisWorkbook.Sheets(1)
    Job_sum_sheet1 shSum
    Job_folder shSum
    Job_sum_sheet2 shSum
    Application.ScreenUpdating = True
End Sub
Sub Job_folder(shSum As Worksheet)
    Dim fso As Object: Set fso = CreateObject("Scripting.Filesystemobject")
    Dim f As Variant
    first_file = True
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        With f
            If fso.GetExtensionName(.Name) Like ("xls*") Then
                If Left(.Name, 2) <> "~$" Then
                    If .Name <> ThisWorkbook.Name Then
                        Application.StatusBar = .Name
                        Job_file f, shSum
                        Application.StatusBar = False
                    End If
                End If
            End If
        End With
        DoEvents
    Next
    Application.CutCopyMode = False
End Sub
Sub Job_file(ByVal sFull As String, shSum As Worksheet)
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFull)
    Job_sheet wb.Sheets(1), shSum
    wb.Close False
End Sub
Sub Job_sheet(sh As Worksheet, shSum As Worksheet)
     
    Dim rTo As Range
    With ThisWorkbook.Sheets(1)
'        If .Cells(1, 1).Value = "" Then
'            Set rTo = .Cells(1, 1)
'        Else
            Set rTo = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
'        End If
    End With
     
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(7, 1), .Cells(y, 5)).AutoFilter Field:=5
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("8:" & y).Copy rTo
        If first_file Then
            .Rows("8:" & y).Copy
            rTo.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            first_file = False
        End If
    End With
    Application.CutCopyMode = False
End Sub
Sub Job_sum_sheet1(shSum As Worksheet)
    With shSum
        .Columns("A:E").Delete Shift:=xlToLeft
    End With
End Sub
Sub Job_sum_sheet2(shSum As Worksheet)
    With shSum
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Then
                .Rows(y).Delete
            End If
        Next
         
        .Parent.Activate
        .Select
        .Cells(1, 1).Select
        .Range(.Cells(1, 1), .Cells(y, 5)).AutoFilter Field:=5, Criteria1:="+"
        .Columns("E:E").EntireColumn.Hidden = True
         
        Application.DisplayAlerts = False
        .Parent.Save
        Application.DisplayAlerts = True
    End With
End Sub
Изменено: Владимир Никифоров - 27.12.2019 11:17:17
 
 
 
#18
27.12.2019 11:36:26
Код
Public first_file As Boolean

Sub Main()
    Application.ScreenUpdating = False
    
    Dim shSum As Worksheet:
    Set shSum = ThisWorkbook.Sheets(1)
    Job_sum_sheet1 shSum
    Job_folder shSum
    Job_sum_sheet2 shSum
    Application.ScreenUpdating = True
End Sub

Sub Job_folder(shSum As Worksheet)
    Dim fso As Object: Set fso = CreateObject("Scripting.Filesystemobject")
    Dim f As Variant
    first_file = True
    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
        With f
            If fso.GetExtensionName(.Name) Like ("xls*") Then
                If Left(.Name, 2) <> "~$" Then
                    If .Name <> ThisWorkbook.Name Then
                        Application.StatusBar = .Name
                        Job_file f, shSum
                        Application.StatusBar = False
                    End If
                End If
            End If
        End With
        DoEvents
    Next
    Application.CutCopyMode = False
End Sub

Sub Job_file(ByVal sFull As String, shSum As Worksheet)
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFull)
    Job_sheet wb.Sheets(1), shSum
    wb.Close False
End Sub

Sub Job_sheet(sh As Worksheet, shSum As Worksheet)
    
    Dim rTo As Range
    With ThisWorkbook.Sheets(1)
'        If .Cells(1, 1).Value = "" Then
'            Set rTo = .Cells(1, 1)
'        Else
            Set rTo = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
'        End If
    End With
    
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(7, 1), .Cells(y, 5)).AutoFilter Field:=5
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Rows("8:" & y).Copy rTo
        If first_file Then
            .Rows("8:" & y).Copy
            rTo.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            first_file = False
        End If
    End With
    Application.CutCopyMode = False
End Sub
Код
Sub Job_sum_sheet1(shSum As Worksheet)
    With shSum
        .Columns("A:E").Delete Shift:=xlToLeft
    End With
End Sub

Sub Job_sum_sheet2(shSum As Worksheet)
    DeleteEmptyRow shSum
    With shSum
        .Parent.Activate
        .Select
        .Cells(1, 1).Select
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(1, 1), .Cells(y, 5)).AutoFilter Field:=5, Criteria1:="+"
        .Columns("E:E").EntireColumn.Hidden = True
        
        Application.DisplayAlerts = False
        .Parent.Save
        Application.DisplayAlerts = True
    End With
End Sub

Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        If y = 1 Then
            ReDim a(1 To 1, 1 To 1)
            a(1, 1) = .Cells(y, 1).Value
        Else
            a = .Range(.Cells(1, 1), .Cells(y, 1))
        End If
        
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
Изменено: МатросНаЗебре - 27.12.2019 11:37:36
 
 
 
#19
27.12.2019 12:11:22
МатросНаЗебре, не могу понять: или лыжи в чём ошибка и какие условия для корректной работы макроса?

Делаю так:
- кладу в 1 папку пустой файл сводного отчёта с шапкой и файлы отчетов-исходников
-открываю файл сводного отчёта
-запускаю макрос.....


-ошибка в строке
Код
.Range(.Cells(1, 1), .Cells(y, 5)).AutoFilter Field:=5, Criteria1:="+"
в блоке Sub Job_sum_sheet2
 
 
 
#20
27.12.2019 12:19:17
Код
Sub Job_sum_sheet2(shSum As Worksheet)
    DeleteEmptyRow shSum
    With shSum
        .Parent.Activate
        .Select
        .Cells(1, 1).Select
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y > 1 Then
            .Range(.Cells(1, 1), .Cells(y, 5)).AutoFilter Field:=5, Criteria1:="+"
            .Columns("E:E").EntireColumn.Hidden = True
        End If
        
        Application.DisplayAlerts = False
        .Parent.Save
        Application.DisplayAlerts = True
    End With
End Sub
Код
Sub Job_sheet(sh As Worksheet, shSum As Worksheet)
    
    Dim rTo As Range
    With ThisWorkbook.Sheets(1)
'        If .Cells(1, 1).Value = "" Then
'            Set rTo = .Cells(1, 1)
'        Else
            Set rTo = .Cells(.Rows.Count, 1).End(xlUp).Cells(2, 1)
'        End If
    End With
    
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        If y > 7 Then
            .Range(.Cells(7, 1), .Cells(y, 5)).AutoFilter Field:=5
            y = .Cells(.Rows.Count, 1).End(xlUp).Row
            .Rows("8:" & y).Copy rTo
            If first_file Then
                .Rows("8:" & y).Copy
                rTo.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                first_file = False
            End If
        End If
    End With
    Application.CutCopyMode = False
End Sub

Для работы с пустыми файлами нужно заменить эти процедуры.

И минутка недоумения. Зачем Вы тестируете на пустых файлах, если у Вас 200 файлов в папке?
Изменено: МатросНаЗебре - 27.12.2019 12:21:44
 
 
 
#21
27.12.2019 12:59:24
Цитата
МатросНаЗебре написал:
И минутка недоумения. Зачем Вы тестируете на пустых файлах, если у Вас 200 файлов в папке?
Я открываю файл сводного отчёта, который изначально пустой, без данных, а файлы-исходники НЕ пустые. :)  
 
 
 
#22
27.12.2019 13:08:15
А я понял, ошибка возникла, когда рядом не было файлов отчётов.
 
 
 
#23
27.12.2019 14:42:27
МатросНаЗебре,
Цитата
МатросНаЗебре написал:
А я понял, ошибка возникла, когда рядом не было файлов отчётов.
Файл отчёта и файлы-исходники находятся в 1 папке, при запуске макроса-ошибка в блоке sum_sheet2.
Это ошибка в макросе или я неверно выполняю какие-то шаги? Уже ум за разум заходит.
 
 
 
#24
27.12.2019 14:48:25
Цитата
Владимир Никифоров написал:
Это ошибка в макросе или я неверно выполняю какие-то шаги?
Сложно сказать, не видя файла. А какая область заполнена на момент появления ошибки?
 
 
 
#25
27.12.2019 15:12:27
МатросНаЗебре,
Цитата
МатросНаЗебре написал:
Сложно сказать, не видя файла. А какая область заполнена на момент появления ошибки?
Вот мои действия пошагово:
- в 1 папку складываю отчёты-исходники и НЕ заполненный файл сводного отчёта с шапкой
- открываю НЕ заполненный файл сводного отчёта (приложил)
- запускаю макрос
- ошибка
Макрос хранится в персональной книге. Грешил на надстройку Office tab, но при отключенной надстройке та же ошибка.
 
 
 
#26
27.12.2019 15:14:48
Вот примеры исходников:
Изменено: Владимир Никифоров - 27.12.2019 15:30:10
 
 
 
#27
27.12.2019 15:31:54
На этих файлах у меня отработало без ошибок. Предположу, что дело не в исходниках.
 
 
 
#28
27.12.2019 15:32:48
Цитата
Владимир Никифоров написал:
Макрос хранится в персональной книге
Нашёл.
Перенесите макрос из персональной книги.
 
 
 
#29
27.12.2019 16:14:38
Цитата
МатросНаЗебре написал:
Нашёл.Перенесите макрос из персональной книги.
Вы правы! Макрос заработал, если хранить в текущей книге, но есть пару багов:
-затирается строка 1 с шапкой
-не копируются 8 (восьмые) строки
-прощу прощения, не указал в задаче, что в итоговом отчёте нужны только строки со значением "+" по столбцу Е, т.е либо не снимать фильтр по столбцу Е в исходнике, либо удалить строки БЕЗ пометки "+" по столбцу Е в итоговом отчёте (в приоритете - скорость работы макроса на большом количестве файлов ~до 250 файлов)
Изменено: Владимир Никифоров - 27.12.2019 16:19:09
 
 
 
#30
28.12.2019 10:37:34
Вот пример того, как отрабатывает макрос
 
 
 
Страницы: 1 2 След.
Наверх