Доброго времени суток, уважаемые, помогите пожалуйста сделать макрос для арифметики в сводной таблице.
Ситуация: данную форму разослали по подведомственным учреждениям, они прислали заполненные (несколько десятков), необходимо сделать что бы в сводной (во вложении) по всем листам книг (в ниже приведенном макросе, находящихся в отдельном файле) производилось сложение числовых значений (рублей, штук и так далее), а результат выводился в своде. Для удобства в данном примере сделан необходимый диапазон для расчета одинаковый, по всем листам с 9 строки и ниже только в столбце E.
[vba]
Код
Sub п5() Dim r As Range, cel As Range, wb As Workbook, awb As Workbook, s$, i& Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(ThisWorkbook.Path & "\files") s = "Обработано:" Set r = Range("E9:E29") 'задание диапазона суммирования Set awb = ThisWorkbook r.ClearContents 'проход по всем файлам в папке "\files" For Each objFile In objFolder.Files Set wb = Workbooks.Open(objFile) i = i + 1 s = s & vbCr & i & "." & objFile 'проход по ячейкам For Each cel In r cel.Value = cel.Value + wb.Sheets("п5").Range(cel.Address) Next wb.Close False Next MsgBox s End Sub
[/vba]
Доброго времени суток, уважаемые, помогите пожалуйста сделать макрос для арифметики в сводной таблице.
Ситуация: данную форму разослали по подведомственным учреждениям, они прислали заполненные (несколько десятков), необходимо сделать что бы в сводной (во вложении) по всем листам книг (в ниже приведенном макросе, находящихся в отдельном файле) производилось сложение числовых значений (рублей, штук и так далее), а результат выводился в своде. Для удобства в данном примере сделан необходимый диапазон для расчета одинаковый, по всем листам с 9 строки и ниже только в столбце E.
[vba]
Код
Sub п5() Dim r As Range, cel As Range, wb As Workbook, awb As Workbook, s$, i& Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(ThisWorkbook.Path & "\files") s = "Обработано:" Set r = Range("E9:E29") 'задание диапазона суммирования Set awb = ThisWorkbook r.ClearContents 'проход по всем файлам в папке "\files" For Each objFile In objFolder.Files Set wb = Workbooks.Open(objFile) i = i + 1 s = s & vbCr & i & "." & objFile 'проход по ячейкам For Each cel In r cel.Value = cel.Value + wb.Sheets("п5").Range(cel.Address) Next wb.Close False Next MsgBox s End Sub
нашелся примерно такой макрос, к сожалению он не удобен для работы, так как складывает ячейки в заданном диапазоне E9:E29 ВСЕХ файлов и только с одного листа (п5). Он мерджит, собирает данные из разных книг в одну, а нам нужно что бы складывал значения ячеек, считал суммы ячеек по всем ЛИСТАМ всех КНИГ и выводил в сводную (частично заполненную в соответствующие ячейки на соответствующих листах), тоесть Е9_книга_одна_лист_один+Е9_книга другая_лист_один+...=Е9_свод_лист_о дин Е9_книга_одна_лист_два+Е9_книга другая_лист_два+...=Е9_свод_лист_два ... так же по следующим ячейкам из заданного диапазона... Е10+Е10+..=Е10_свод и так далее, Очень бы хотелось что бы считало по заданному в диалоговом окне диапазону ячеек (удобно сделанному в нижеприведенном макросе, там либо выделить надо либо указать начальную и он тогда будет собирать данные из всех нижерасположенных ячеек), что бы каждый раз в макросе не прописывать нужный лист, нужный диапазон... и использовать в работе на постоянной основе для сложения значений в других таблицах одного формата. [vba]
Код
Option Explicit
Sub Consolidated_Range_of_Books_and_Sheets() Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long Dim oAwb As String, sCopyAddress As String, sSheetName As String Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles Dim wbAct As Workbook Dim bPasteValues As Boolean
On Error Resume Next 'Выбираем диапазон выборки с книг Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) 'для указания диапазона без диалогового окна: 'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный 'Если диапазон не выбран - завершаем процедуру If iBeginRange Is Nothing Then Exit Sub 'Указываем имя листа 'Допустимо указывать в имени листа символы подставки ? и *. 'Если указать только * то данные будут собираться со всех листов sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") 'Если имя листа не указано - данные будут собраны со вех листов If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 'Запрос - вставлять на результирующий лист все данные 'или только значения ячеек (без формул и форматов) bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes) 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True) If VarType(avFiles) = vbBoolean Then Exit Sub bPolyBooks = True lCol = 1 Else
[/vba]
нашелся примерно такой макрос, к сожалению он не удобен для работы, так как складывает ячейки в заданном диапазоне E9:E29 ВСЕХ файлов и только с одного листа (п5). Он мерджит, собирает данные из разных книг в одну, а нам нужно что бы складывал значения ячеек, считал суммы ячеек по всем ЛИСТАМ всех КНИГ и выводил в сводную (частично заполненную в соответствующие ячейки на соответствующих листах), тоесть Е9_книга_одна_лист_один+Е9_книга другая_лист_один+...=Е9_свод_лист_о дин Е9_книга_одна_лист_два+Е9_книга другая_лист_два+...=Е9_свод_лист_два ... так же по следующим ячейкам из заданного диапазона... Е10+Е10+..=Е10_свод и так далее, Очень бы хотелось что бы считало по заданному в диалоговом окне диапазону ячеек (удобно сделанному в нижеприведенном макросе, там либо выделить надо либо указать начальную и он тогда будет собирать данные из всех нижерасположенных ячеек), что бы каждый раз в макросе не прописывать нужный лист, нужный диапазон... и использовать в работе на постоянной основе для сложения значений в других таблицах одного формата. [vba]
Код
Option Explicit
Sub Consolidated_Range_of_Books_and_Sheets() Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long Dim oAwb As String, sCopyAddress As String, sSheetName As String Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer Dim wsSh As Worksheet, wsDataSheet As Worksheet, bPolyBooks As Boolean, avFiles Dim wbAct As Workbook Dim bPasteValues As Boolean
On Error Resume Next 'Выбираем диапазон выборки с книг Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) 'для указания диапазона без диалогового окна: 'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный 'Если диапазон не выбран - завершаем процедуру If iBeginRange Is Nothing Then Exit Sub 'Указываем имя листа 'Допустимо указывать в имени листа символы подставки ? и *. 'Если указать только * то данные будут собираться со всех листов sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") 'Если имя листа не указано - данные будут собраны со вех листов If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 'Запрос - вставлять на результирующий лист все данные 'или только значения ячеек (без формул и форматов) bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes) 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True) If VarType(avFiles) = vbBoolean Then Exit Sub bPolyBooks = True lCol = 1 Else
avFiles = Array(ThisWorkbook.FullName) End If 'отключаем обновление экрана, автопересчет формул и отслеживание событий 'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды With Application lCalc = .Calculation .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With 'создаем новый лист в книге для сбора Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) 'если нужно сделать сбор данных на новый лист книги с кодом 'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 'цикл по книгам For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Set wbAct = Workbooks.Open(Filename:=avFiles(li)) Else Set wbAct = ThisWorkbook End If oAwb = wbAct.Name 'цикл по листам For Each wsSh In wbAct.Worksheets If wsSh.Name Like sSheetName Then 'Если имя листа совпадает с именем листа, в который собираем данные 'и сбор идет только с активной книги - то переходим к следующему листу If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_ With wsSh Select Case iBeginRange.Count Case 1 'собираем данные начиная с указанной ячейки и до конца данных lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = .Cells.SpecialCells(xlLastCell).Column sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address Case Else 'собираем данные с фиксированного диапазона sCopyAddress = iBeginRange.Address End Select lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1 'определяем для копирования диапазон только заполненных данных на листе Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress)) 'вставляем имя книги, с которой собраны данные If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb 'если вставляем только значения и форматы ячеек If bPasteValues Then rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats Else 'если вставляем все данные ячеек(значения, формулы, форматы и т.д.) rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol) End If End With End If NEXT_: Next wsSh If bPolyBooks Then wbAct.Close False Next li With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With End Sub
[/vba]
продолжение: [vba]
Код
avFiles = Array(ThisWorkbook.FullName) End If 'отключаем обновление экрана, автопересчет формул и отслеживание событий 'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды With Application lCalc = .Calculation .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With 'создаем новый лист в книге для сбора Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)) 'если нужно сделать сбор данных на новый лист книги с кодом 'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 'цикл по книгам For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Set wbAct = Workbooks.Open(Filename:=avFiles(li)) Else Set wbAct = ThisWorkbook End If oAwb = wbAct.Name 'цикл по листам For Each wsSh In wbAct.Worksheets If wsSh.Name Like sSheetName Then 'Если имя листа совпадает с именем листа, в который собираем данные 'и сбор идет только с активной книги - то переходим к следующему листу If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_ With wsSh Select Case iBeginRange.Count Case 1 'собираем данные начиная с указанной ячейки и до конца данных lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row iLastColumn = .Cells.SpecialCells(xlLastCell).Column sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address Case Else 'собираем данные с фиксированного диапазона sCopyAddress = iBeginRange.Address End Select lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1 'определяем для копирования диапазон только заполненных данных на листе Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress)) 'вставляем имя книги, с которой собраны данные If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb 'если вставляем только значения и форматы ячеек If bPasteValues Then rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats Else 'если вставляем все данные ячеек(значения, формулы, форматы и т.д.) rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol) End If End With End If NEXT_: Next wsSh If bPolyBooks Then wbAct.Close False Next li With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With End Sub