Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Выбор папки для обработки файлов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выбор папки для обработки файлов (Макросы/Sub)
Выбор папки для обработки файлов
bosika Дата: Воскресенье, 28.11.2021, 07:08 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010, 2013, 2016
Приветствую Вас знатоки своего дела! Имеется макрос для обработки файлов (суммирование), но только с указанной в коде папки (2021). Сам файл для сбора присылаемых данных лежит вне этой папки, назовем ее например 2021 (как в макросе). Табличные данные присылают порядка 25 подчиненных организации. Для каждой организации создается отдельная папка по территориальному ее нахождению. Кроме файла Excel, в этой папке находятся сканированный файл в pdf. Самому это решение не осилить.
Помогите подправить макрос для сбора данных не с указанной в макросе папке, а с выбором папки самостоятельно. Если можно, конечно, то чтоб сбор данных шел и из подпапок файлов Excel.

Заранее благодарен.

Сам макрос
[vba]
Код
Sub сумма()
'отключаем обновление экрана
Application.ScreenUpdating = False
'Отключаем автопересчет формул
'Application.Calculation = xlCalculationManual
'Отключаем отслеживание событий
Application.EnableEvents = False

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 & "\2021")
s = "Обработано:"
Set r = Range("D17:E21,G17:H21,D23:E27,G23:H27,D29:E34,G29:H34,D35:E35,D37:E39,G37:H39,D42:E44,G42:H44") 'задание диапазона суммирования
Set awb = ThisWorkbook
r.ClearContents
'проход по всем файлам в папке "\2021"
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("1_РЕЗ_ЧС").Range(cel.Address)
Next
wb.Close False
Next
MsgBox s

'Возвращаем обновление экрана
Application.ScreenUpdating = True
'Возвращаем автопересчет формул
'Application.Calculation = xlCalculationAutomatic
'Включаем отслеживание событий
Application.EnableEvents = True

End Sub
[/vba]


Начинающий. Много и долго не пинать. Больно однако.

Сообщение отредактировал bosika - Воскресенье, 28.11.2021, 07:17
 
Ответить
СообщениеПриветствую Вас знатоки своего дела! Имеется макрос для обработки файлов (суммирование), но только с указанной в коде папки (2021). Сам файл для сбора присылаемых данных лежит вне этой папки, назовем ее например 2021 (как в макросе). Табличные данные присылают порядка 25 подчиненных организации. Для каждой организации создается отдельная папка по территориальному ее нахождению. Кроме файла Excel, в этой папке находятся сканированный файл в pdf. Самому это решение не осилить.
Помогите подправить макрос для сбора данных не с указанной в макросе папке, а с выбором папки самостоятельно. Если можно, конечно, то чтоб сбор данных шел и из подпапок файлов Excel.

Заранее благодарен.

Сам макрос
[vba]
Код
Sub сумма()
'отключаем обновление экрана
Application.ScreenUpdating = False
'Отключаем автопересчет формул
'Application.Calculation = xlCalculationManual
'Отключаем отслеживание событий
Application.EnableEvents = False

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 & "\2021")
s = "Обработано:"
Set r = Range("D17:E21,G17:H21,D23:E27,G23:H27,D29:E34,G29:H34,D35:E35,D37:E39,G37:H39,D42:E44,G42:H44") 'задание диапазона суммирования
Set awb = ThisWorkbook
r.ClearContents
'проход по всем файлам в папке "\2021"
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("1_РЕЗ_ЧС").Range(cel.Address)
Next
wb.Close False
Next
MsgBox s

'Возвращаем обновление экрана
Application.ScreenUpdating = True
'Возвращаем автопересчет формул
'Application.Calculation = xlCalculationAutomatic
'Включаем отслеживание событий
Application.EnableEvents = True

End Sub
[/vba]

Автор - bosika
Дата добавления - 28.11.2021 в 07:08
svp Дата: Воскресенье, 28.11.2021, 09:32 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Может эта статья поможет: https://www.excel-vba.ru/chto-um....ovpapki
 
Ответить
СообщениеМожет эта статья поможет: https://www.excel-vba.ru/chto-um....ovpapki

Автор - svp
Дата добавления - 28.11.2021 в 09:32
bosika Дата: Воскресенье, 28.11.2021, 09:39 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010, 2013, 2016
svp, Перепробывал несколько вариантов на разных сайтах, то макрос не выполняется, то вылетает сам файл.


Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
Сообщениеsvp, Перепробывал несколько вариантов на разных сайтах, то макрос не выполняется, то вылетает сам файл.

Автор - bosika
Дата добавления - 28.11.2021 в 09:39
jun Дата: Воскресенье, 28.11.2021, 09:48 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

bosika, посмотрите:
[vba]
Код
Sub сумма()
'отключаем обновление экрана
Application.ScreenUpdating = False
'Отключаем автопересчет формул
'Application.Calculation = xlCalculationManual
'Отключаем отслеживание событий
Application.EnableEvents = False

Dim r As Range, cel As Range, wb As Workbook, awb As Workbook, s$, i&
Dim objFSO As FileDialog, objFolder As Object
Dim objFile, FS As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set objFSO = Application.FileDialog(msoFileDialogFolderPicker)

objFSO.AllowMultiSelect = False
objFSO.Show
Set objFolder = FS.getfolder(objFSO.SelectedItems(1))
s = "Обработано:"
Set r = Range("D17:E21,G17:H21,D23:E27,G23:H27,D29:E34,G29:H34,D35:E35,D37:E39,G37:H39,D42:E44,G42:H44") 'задание диапазона суммирования
Set awb = ThisWorkbook
r.ClearContents
'проход по всем файлам в папке "\2021"
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("1_РЕЗ_ЧС").Range(cel.Address)
Next
wb.Close False
Next objFile
MsgBox s

'Возвращаем обновление экрана
Application.ScreenUpdating = True
'Возвращаем автопересчет формул
'Application.Calculation = xlCalculationAutomatic
'Включаем отслеживание событий
Application.EnableEvents = True

End Sub
[/vba]


Сообщение отредактировал jun - Воскресенье, 28.11.2021, 10:25
 
Ответить
Сообщениеbosika, посмотрите:
[vba]
Код
Sub сумма()
'отключаем обновление экрана
Application.ScreenUpdating = False
'Отключаем автопересчет формул
'Application.Calculation = xlCalculationManual
'Отключаем отслеживание событий
Application.EnableEvents = False

Dim r As Range, cel As Range, wb As Workbook, awb As Workbook, s$, i&
Dim objFSO As FileDialog, objFolder As Object
Dim objFile, FS As Object
Set FS = CreateObject("Scripting.FileSystemObject")
Set objFSO = Application.FileDialog(msoFileDialogFolderPicker)

objFSO.AllowMultiSelect = False
objFSO.Show
Set objFolder = FS.getfolder(objFSO.SelectedItems(1))
s = "Обработано:"
Set r = Range("D17:E21,G17:H21,D23:E27,G23:H27,D29:E34,G29:H34,D35:E35,D37:E39,G37:H39,D42:E44,G42:H44") 'задание диапазона суммирования
Set awb = ThisWorkbook
r.ClearContents
'проход по всем файлам в папке "\2021"
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("1_РЕЗ_ЧС").Range(cel.Address)
Next
wb.Close False
Next objFile
MsgBox s

'Возвращаем обновление экрана
Application.ScreenUpdating = True
'Возвращаем автопересчет формул
'Application.Calculation = xlCalculationAutomatic
'Включаем отслеживание событий
Application.EnableEvents = True

End Sub
[/vba]

Автор - jun
Дата добавления - 28.11.2021 в 09:48
bosika Дата: Воскресенье, 28.11.2021, 10:19 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010, 2013, 2016
jun, Спасибо большое. Первый макрос пришлось останавливать через диспетчер задач. Цикл шел непрерывно. Второй макрос пошел. Спасибо огромное. От рутинной работы меня спасли.


Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
Сообщениеjun, Спасибо большое. Первый макрос пришлось останавливать через диспетчер задач. Цикл шел непрерывно. Второй макрос пошел. Спасибо огромное. От рутинной работы меня спасли.

Автор - bosika
Дата добавления - 28.11.2021 в 10:19
bosika Дата: Воскресенье, 28.11.2021, 10:20 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010, 2013, 2016
jun, Плюсую!


Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
Сообщение jun, Плюсую!

Автор - bosika
Дата добавления - 28.11.2021 в 10:20
jun Дата: Воскресенье, 28.11.2021, 10:26 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 84
Репутация: 18 ±
Замечаний: 0% ±

bosika, спасибо!

Оставил в своём предыдущем сообщении рабочий вариант
 
Ответить
Сообщениеbosika, спасибо!

Оставил в своём предыдущем сообщении рабочий вариант

Автор - jun
Дата добавления - 28.11.2021 в 10:26
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выбор папки для обработки файлов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!