Приветствую! имеется макрос, который собирает информацию с разных книг и суммирует необходимые ячейки [vba]
Код
Sub IMPORT() Dim srcBook Set wb = ThisWorkbook Set wf = WorksheetFunction Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Январь.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Январь.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B6") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B7") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B5:B7").Font.Color = vbRed srcBook.Close SaveChanges:=False End If Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Февраль.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Февраль.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B9") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B10") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B11") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B12") = wf.Sum(srcBook.Sheets("День4").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B9:B12").Font.Color = vbRed srcBook.Close SaveChanges:=False End If Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Март.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Март.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B14") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B15") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B16") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B14:B16").Font.Color = vbRed srcBook.Close SaveChanges:=False ' и так далее... End Sub
[/vba]
Проблема заключается в том, что есть Столбец А, где указано текстом "Понедельник", "Вторник", "Среда" и т.д., иногда бывает что нет целой строки, поэтому макрос должен переходить на следующую строчку. Например, если ячейка А11 = "Среда", то выполняется макрос [vba]
[/vba] если другое значение, то следующая строка макроса по порядку...при этом все следующие значения должны идти в макросе уже с -1 ячейкой.
Приветствую! имеется макрос, который собирает информацию с разных книг и суммирует необходимые ячейки [vba]
Код
Sub IMPORT() Dim srcBook Set wb = ThisWorkbook Set wf = WorksheetFunction Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Январь.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Январь.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B6") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B7") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B5:B7").Font.Color = vbRed srcBook.Close SaveChanges:=False End If Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Февраль.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Февраль.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B9") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B10") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B11") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B12") = wf.Sum(srcBook.Sheets("День4").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B9:B12").Font.Color = vbRed srcBook.Close SaveChanges:=False End If Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Март.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Март.xls", ReadOnly:=True, UpdateLinks:=0) wb.Sheets("Главная").Range("B14") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B15") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B16") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) wb.Sheets("Главная").Range("B14:B16").Font.Color = vbRed srcBook.Close SaveChanges:=False ' и так далее... End Sub
[/vba]
Проблема заключается в том, что есть Столбец А, где указано текстом "Понедельник", "Вторник", "Среда" и т.д., иногда бывает что нет целой строки, поэтому макрос должен переходить на следующую строчку. Например, если ячейка А11 = "Среда", то выполняется макрос [vba]
Sub IMPORT() Arr = [{"Понедельник", "Вторник", "Среда"}]
Dim srcBook Set wb = ThisWorkbook Set wf = WorksheetFunction Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Январь.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Январь.xls", ReadOnly:=True, UpdateLinks:=0) With wb.Sheets("Главная") If Not inArr(Arr, .Range("A5")) Then .Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) If Not inArr(Arr, .Range("A6")) Then .Range("B6") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) If Not inArr(Arr, .Range("A7")) Then .Range("B7") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) .Range("B5:B7").Font.Color = vbRed End With srcBook.Close SaveChanges:=False End If ' и так далее... End Sub
Function inArr(Arr, el) As Boolean For Each t In Arr If t = el Then inArr = True: Exit Function Next t inArr = False End Function
[/vba]
akaDemik, Не совсем понял ТЗ. Может так [vba]
Код
Sub IMPORT() Arr = [{"Понедельник", "Вторник", "Среда"}]
Dim srcBook Set wb = ThisWorkbook Set wf = WorksheetFunction Dim oFileSystemObject As Object: Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") If oFileSystemObject.FileExists(wb.Path & "\Январь.xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\Январь.xls", ReadOnly:=True, UpdateLinks:=0) With wb.Sheets("Главная") If Not inArr(Arr, .Range("A5")) Then .Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11")) If Not inArr(Arr, .Range("A6")) Then .Range("B6") = wf.Sum(srcBook.Sheets("День2").Range("A3,A7,A9,A11")) If Not inArr(Arr, .Range("A7")) Then .Range("B7") = wf.Sum(srcBook.Sheets("День3").Range("A3,A7,A9,A11")) .Range("B5:B7").Font.Color = vbRed End With srcBook.Close SaveChanges:=False End If ' и так далее... End Sub
Function inArr(Arr, el) As Boolean For Each t In Arr If t = el Then inArr = True: Exit Function Next t inArr = False End Function
Может быть не совсем корректно описал задачу, попробую перефразировать: В основной книге (5264877.xslm), на листе "Главная", есть столбец А, где в диапазоне А5:А16 находится уникальный текст для поиска, для примера это "2Среда". Макрос должен отработать таким образом что, сначала открываем дополнительную книгу (Февраль.xls), находим в основной книге, в диапазоне А5:А16 необходимый текст "2Среда", потом переходим на дополнительную книгу и вставляем сумму значений [vba]
[/vba] в ячейку B:n из основной книги, где n - это номер строки, где находится "2Среда", в данном примере это B:11 Если "2Среда" в необходимом диапазоне не найдено, то переходим к поиску "2Четверг" и соответственно вставляем сумму значений [vba]
[/vba] в ячейку B:n из основной книги, где n - это номер строки, где находится "2Четверг", в данном примере это B:12
Может быть не совсем корректно описал задачу, попробую перефразировать: В основной книге (5264877.xslm), на листе "Главная", есть столбец А, где в диапазоне А5:А16 находится уникальный текст для поиска, для примера это "2Среда". Макрос должен отработать таким образом что, сначала открываем дополнительную книгу (Февраль.xls), находим в основной книге, в диапазоне А5:А16 необходимый текст "2Среда", потом переходим на дополнительную книгу и вставляем сумму значений [vba]
[/vba] в ячейку B:n из основной книги, где n - это номер строки, где находится "2Среда", в данном примере это B:11 Если "2Среда" в необходимом диапазоне не найдено, то переходим к поиску "2Четверг" и соответственно вставляем сумму значений [vba]
If Not inArr(Arr, .Range(["A5")) Then .Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11"))
может не разобрался в функции, но из того что вижу, не подходит т.к. писал выше, строка куда необходимо вставлять значение, может отсутствовать она может быть как "B5" так и "B6", "B7","B8" и т.д., в зависимости от того какой текст находится на Листе "Главная" в ячейке "A5"
If Not inArr(Arr, .Range(["A5")) Then .Range("B5") = wf.Sum(srcBook.Sheets("День1").Range("A3,A7,A9,A11"))
может не разобрался в функции, но из того что вижу, не подходит т.к. писал выше, строка куда необходимо вставлять значение, может отсутствовать она может быть как "B5" так и "B6", "B7","B8" и т.д., в зависимости от того какой текст находится на Листе "Главная" в ячейке "A5"akaDemik
akaDemik, Все равно не понятно. Открываю файл "Monday". Смотрю столбик "А" беру значение "1Понедельник" Это значение нигде в файлах не встречается и другие тоже Покажите какой результат ожидаете
akaDemik, Все равно не понятно. Открываю файл "Monday". Смотрю столбик "А" беру значение "1Понедельник" Это значение нигде в файлах не встречается и другие тоже Покажите какой результат ожидаетеmiver
Sub IMPORT() Dim srcBook As Workbook Dim ws As Worksheet
Set wb = ThisWorkbook Set ws = wb.Sheets("Главная") Set wf = WorksheetFunction Dim oFileSystemObject As Object Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") Mon = [{"Январь","Февраль","Март"}]
Application.ScreenUpdating = False For Each m In Mon If oFileSystemObject.FileExists(wb.Path & "\" & m & ".xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\" & m & ".xls", ReadOnly:=True, UpdateLinks:=0) For Each sh In srcBook.Sheets Set wc = ws.Range("A:A").Find(sh.Name) If TypeName(wc) = "Range" Then wc.Offset(0, 1).Value = wf.Sum(sh.Range("A3,A7,A9,A11")) wc.Offset(0, 1).Font.Color = vbRed End If Next sh srcBook.Close SaveChanges:=False End If Next m Application.ScreenUpdating = True End Sub
[/vba]
akaDemik, Так? [vba]
Код
Sub IMPORT() Dim srcBook As Workbook Dim ws As Worksheet
Set wb = ThisWorkbook Set ws = wb.Sheets("Главная") Set wf = WorksheetFunction Dim oFileSystemObject As Object Set oFileSystemObject = CreateObject("Scripting.FileSystemObject") Mon = [{"Январь","Февраль","Март"}]
Application.ScreenUpdating = False For Each m In Mon If oFileSystemObject.FileExists(wb.Path & "\" & m & ".xls") Then Set srcBook = Workbooks.Open(Filename:=wb.Path & "\" & m & ".xls", ReadOnly:=True, UpdateLinks:=0) For Each sh In srcBook.Sheets Set wc = ws.Range("A:A").Find(sh.Name) If TypeName(wc) = "Range" Then wc.Offset(0, 1).Value = wf.Sum(sh.Range("A3,A7,A9,A11")) wc.Offset(0, 1).Font.Color = vbRed End If Next sh srcBook.Close SaveChanges:=False End If Next m Application.ScreenUpdating = True End Sub
Да, очень похоже на то что надо, осталось пару вопросов: 1. Если файл Апрель, будет *.xlsx ? 2. По коду я понял что если название листа точно совпадает названию в столбце "A:A", тогда оно добавляется в ячейку В:n, но иногда название листа бывает сокращенным, "1Пон", "1Понед", "1Mond" и т.д. грубо говоря я знаю что в книгах Январь, Февраль и Март названия листов имеют точное совпадение с текстом в столбце "A:A", но в книге Апрель.xlsx название листа "4Вторн" равно тексту "4Вторник" из столбца "A:A" главной книги; в книге Май.xlsx название листа "5Ср" равно тексту "5 Среда" из столбца "A:A" главной книги...и т.д.
Да, очень похоже на то что надо, осталось пару вопросов: 1. Если файл Апрель, будет *.xlsx ? 2. По коду я понял что если название листа точно совпадает названию в столбце "A:A", тогда оно добавляется в ячейку В:n, но иногда название листа бывает сокращенным, "1Пон", "1Понед", "1Mond" и т.д. грубо говоря я знаю что в книгах Январь, Февраль и Март названия листов имеют точное совпадение с текстом в столбце "A:A", но в книге Апрель.xlsx название листа "4Вторн" равно тексту "4Вторник" из столбца "A:A" главной книги; в книге Май.xlsx название листа "5Ср" равно тексту "5 Среда" из столбца "A:A" главной книги...и т.д.akaDemik
Можно перебирать все файлы в определённой папке без учета названий Пункт 2: Перед поиском делай замену названий на один стандартный. Самое простое решение - сделать словарь с синонимами и заменять "Вт", "Вторн" на "Вторник"
Можно перебирать все файлы в определённой папке без учета названий Пункт 2: Перед поиском делай замену названий на один стандартный. Самое простое решение - сделать словарь с синонимами и заменять "Вт", "Вторн" на "Вторник"miver
Сообщение отредактировал miver - Пятница, 23.10.2015, 14:41
Перед поиском делай замену названий на один стандартный.
да, это хорошее предложение [vba]
Код
If sh.CodeName = "4Вторн" Then sh.Name = "4Вторник": Exit For ElseIf sh.CodeName = "4Втор" Then sh.Name = "4Вторник": Exit For ElseIf sh.CodeName = "4Вт" Then sh.Name = "4Вторник": Exit For Next
Перед поиском делай замену названий на один стандартный.
да, это хорошее предложение [vba]
Код
If sh.CodeName = "4Вторн" Then sh.Name = "4Вторник": Exit For ElseIf sh.CodeName = "4Втор" Then sh.Name = "4Вторник": Exit For ElseIf sh.CodeName = "4Вт" Then sh.Name = "4Вторник": Exit For Next
Не получается у меня... как и писал выше, первая проблема, это с файлом Март.xlsx, пробовал добавить в код *.xlsx, но обработка не проходит... [vba]
Код
(wb.Path & "\" & m & ".xls" & ".xlsx")
[/vba] вторая проблема, это с переименованием листов, выбивает ошибку а третья проблема, то что я и опасался с самого начала, у большинства файлов одинаковая структура, но есть файлы, у который нужные данные находятся на одном листе (Апрель.xls)
Не получается у меня... как и писал выше, первая проблема, это с файлом Март.xlsx, пробовал добавить в код *.xlsx, но обработка не проходит... [vba]
Код
(wb.Path & "\" & m & ".xls" & ".xlsx")
[/vba] вторая проблема, это с переименованием листов, выбивает ошибку а третья проблема, то что я и опасался с самого начала, у большинства файлов одинаковая структура, но есть файлы, у который нужные данные находятся на одном листе (Апрель.xls)akaDemik