Здравейте, направих макрос, който обобщава данните от всички файлове, които се намират в една папка.
Кода е оптимизиран да работи с толкова колони, колкото е необходимо.
1. Стартира се.
2. В появилия се прозорец се посочва папката, в която се намират файловете.
3. Изтрива всички данни (без заглавния ред) от лист Summary на файла с макроса - в случай, че сме забравили да изтрием предишни данни.
4. Отваря всеки файл в зададената папка, копира информацията от определения лист, поставя името на файла, от който са взети данните. В колона В се поставя забележка ако в обработвания файл няма данни, липсва листа със зададеното в макроса име (аз съм задала Data, но може да се промени. Поставила съм коментар в процедурата къде трябва да се направи.
Също така отбелязва ако в обработвания лист има информация в повече колони. (сравнява колоните във файла с макроса с тези в обработвания файл)
5. Да не забравя - името на листа във файла с макроса, в който ще се обединяват данните е Summary. Ако ще се използва друго име, то трябва да се промени и в макроса. Написала съм къде - само на едно място в началото.
6. Когато приключи с обработката се появява съобщение за това.
По време на работата на макроса няма да се вижда какво се случва. Това е за по-бърза обработка.
Възможно е да се появи грешка, която не е предвидена в процедурата. В този случай ще се покаже съобщение по време на обработката на кой файл се е случило. Надявам се да съм обхванала възможните грешки, които в този случай биха възникнали. Мисля си, че ще възникне грешка ако има диаграма, заключени клетки, евентуално пивот.... Но ми се струва, че при така зададения въпрос не е необходимо да се усложнява процедурата.
Ето го и макроса (не пропускайте да копирате и функцията). Започва от следващия ред (ще запиша и къде свършва, защото обикновено пиша мноого коментари в процедурите и това може да е объркващо):
Option Explicit
'Функцията ще се използва за проверка дали е наличен зададения лист
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function
Sub CombineHereAllExcelFilesInFolder()
'Копира данните на конкретен лист от всички екселски
'файлове в посочена папка в определен лист на този файл
On Error GoTo Error_handler
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim LastRow As Long
Dim LastColumn As Long
Dim MyLastRow As Long
Dim MyLastColumn As Long
Dim MySheet As String
MySheet = "Summary" 'Тук в кавичките може да се постави друго име на листа в този файл
Dim OtherSheet As String
OtherSheet = "Data" 'Тук в кавичките може да се постави друго име на листа в обработваните файлове
'Оптимизира скоростта на работа
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Изтрива всичко в лист Summary на този файл (без заглавния ред)
ThisWorkbook.Worksheets(MySheet).Rows("2:" & Rows.Count).Clear
'Връща пътя към зададена от потребителя папка
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Посочете желаната папка"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'В случай на избор на бутон Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Посочва се разширението на файловете за обработка (трябва да включва "*")
'Тук може да се промени разширението на .xls, но не е тествано.
myExtension = "*.xlsx"
'Определя се избрания път към папката заедно с разширението на целевите файлове
myFile = Dir(myPath & myExtension)
'Запомня номера на последната колона в този файл
MyLastColumn = ThisWorkbook.Worksheets(MySheet).Cells.Find _
("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
'Направи следното за всеки екселски файл в папката започва тук
Do While myFile <> ""
'Определяне и запомняне на пътя и името на отворения файл.
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Проверява дали има лист Data
If WorksheetExists(OtherSheet) Then
'Проверява дали има данни в лист Data
If WorksheetFunction.CountA(wb.Worksheets(OtherSheet).Cells) <> 0 Then
'Определя и запомня номера на последния ред и последната колона
'на обработвания файл и на последния ред на този файл
LastRow = wb.Worksheets(OtherSheet).Cells.Find _
("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastColumn = wb.Worksheets(OtherSheet).Cells.Find _
("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
MyLastRow = ThisWorkbook.Worksheets(MySheet). _
Cells(ThisWorkbook.Worksheets(MySheet).Rows.Count, "A").End(xlUp).Row
'Копира областта с данни в първия празен ред
Range(Cells(2, 1), Cells(LastRow, LastColumn)).Copy _
Destination:=ThisWorkbook.Worksheets(MySheet).Range("C" & MyLastRow + 1)
'Поставя името на файла в колона А за цялата област с данни на обработвания лист
'Ако се запище wb.Path & "\" & wb.Name вместо wb.Name ще се изписва и пътя към файла
ThisWorkbook.Worksheets(MySheet).Range _
("A" & MyLastRow + 1, "A" & MyLastRow + LastRow - 1) = wb.Name
'Проверява дали броят на колоните са еднакви с първоначалните
'При разлика поставя коментар в колона B
'Разликата от 2 не се взема предвид
If MyLastColumn - 2 = LastColumn Then
ElseIf MyLastColumn - 2 < LastColumn Then
ThisWorkbook.Worksheets(MySheet).Range _
("B" & MyLastRow + 1, "B" & MyLastRow + LastRow - 1) = "Има информация в повече колони."
ElseIf MyLastColumn - 2 > LastColumn Then
ThisWorkbook.Worksheets(MySheet).Range _
("B" & MyLastRow + 1, "B" & MyLastRow + LastRow - 1) = "Има липсващи колони."
End If
'Записва в първия празен ред името на файла и коментар ако лист Data е празен.
ElseIf WorksheetFunction.CountA(wb.Worksheets(OtherSheet).Cells) = 0 Then
MyLastRow = ThisWorkbook.Worksheets(MySheet). _
Cells(ThisWorkbook.Worksheets(MySheet).Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets(MySheet).Range _
("A" & MyLastRow + 1) = wb.Name 'wb.Path & "\" & wb.Name вместо wb.Name и за пътя
ThisWorkbook.Worksheets(MySheet).Range _
("B" & MyLastRow + 1) = "Лист " & OtherSheet & " е празен."
End If
Else
'Записва в първия празен ред името на файла и коментар ако липсва лист Data.
MyLastRow = ThisWorkbook.Worksheets(MySheet). _
Cells(ThisWorkbook.Worksheets(MySheet).Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Worksheets(MySheet).Range _
("A" & MyLastRow + 1) = wb.Name 'wb.Path & "\" & wb.Name вместо wb.Name и за пътя
ThisWorkbook.Worksheets(MySheet).Range _
("B" & MyLastRow + 1) = "Лист " & OtherSheet & " липсва."
End If
'Затваря файла без запазване на промени
wb.Close SaveChanges:=False
'Взема името на следващия файл
myFile = Dir
Loop 'Направи следното за всеки екселски файл в папката завършва тук
'Съобщение след приключване на задачата
MsgBox "Задачата е изпълнена!"
ResetSettings:
'Връща обратно настройките за оптимизиране на скоростта на работа към тези по подразбиране.
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub
Error_handler:
MsgBox "Възникна грешка при обработката на файл: " & vbNewLine & vbNewLine _
& wb.Name & vbNewLine & vbNewLine & "Файлът ще се затвори." & vbNewLine _
& "Останалите файлове няма да бъдат обработени."
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Макроса свършва на горния ред.
Има много коментари, с които макроса изглежда огромен, но пък ориентират какво се случва.
Надявам се процедурата да е от полза.
