Нужна Ваша помощь ???. допилить макрос. Суть макроса следующая: Присланные от регионов файла хранятся в одной папке. Файл имеет название такое же как и компания (в сводном файле это столбец В). Данные файлы необходимо скопировать в сводный файл (Service ФХД_Сводная) в лист той компании, как называется присланный от компании файл, т.е. с название компании. Копирование на данный момент происходит, начиная с ячейки В 142 каждого вложенного файла в сводный. В итоге хотелось бы получить от макроса открытие всех файлов в папке присланных регионами и копирование их в сводный файл в лист с одинаковым названием.
Прописал макрос путем проб и ошибок, файл в приложении. Может не работать из-за расширения открываемых листов. Вопрос к знающим людям: если листы которые присылают регионы имеют разное расширение, допустим: .xlsm и .xls или .xlsx Как прописать в макросе открытие листов с разным расширением?
можете получать имя листа отрезав от имени файла расширение
Sub test()
Debug.Print SplitFileName(ThisWorkbook.FullName)
End Sub
Function SplitFileName(sFullPath As String) As String
'получить имя файла без расширения
Dim str() As String, temp As String
str = Split(sFullPath, Application.PathSeparator)
temp = str(UBound(str))
str = Split(temp, ".")
SplitFileName = Mid(temp, 1, Len(temp) - Len(str(UBound(str))) - 1)
End Function
Ваш код я переписал и сохранил в модуле4
сюда выкладываю листинг модуля
Option Explicit
Sub Копирование_информации_регионов()
Dim FilesToOpen$(), ListName$
Dim x, i&, iRow&
Dim importWB As Workbook, shIn As Worksheet, shOut As Worksheet
'вызываем диалог выбора файлов для импорта
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Files to Merge"
.InitialFileName = ThisWorkbook.Path 'здесь можете указать свой путь к файлам "по умолчанию"
.Filters.Clear: .Filters.Add "Excel files", "*.xls*" 'что бы отображалимь только Excel'евские файлы с данными
.Show
x = .SelectedItems.Count
Select Case x
Case 0
MsgBox "Не выбрано ни одного файла!": Exit Sub
Case Else
ReDim FilesToOpen(1 To x)
For i = 1 To x
FilesToOpen(i) = .SelectedItems(i)
Next i
End Select
End With
' при таком выполнении кода, обновление экрана можно не отключать
' Application.ScreenUpdating = False 'отключаем обновление экрана для скорости
' а вот обработку событий я бы отключил
Application.EnableEvents = False 'Не обрабатывать события.
For Each x In FilesToOpen
Set importWB = Workbooks.Open(x) 'открываем выбранные файлы
Set shOut = importWB.Sheets(1) 'лист откуда будем брать данные
' ListName = shOut.Range("B1").Text 'присваиваем имя переменной из ячейки В1 с названием компании
ListName = SplitFileName(CStr(x)) 'или присваиваем имя обрабатываемого файла без расширения
Set shIn = ThisWorkbook.Sheets(ListName) 'лист куда будем копировать
iRow = shIn.Cells(shIn.Rows.Count, 1).End(xlUp).Row - 33 'находим строку последней таблицы для внесения данных
' копируем данные из открытого файла по порядку
shOut.Range("B4:M9").Copy shIn.Cells(iRow, 2) 'Текущие расходы
shOut.Range("B11:M14").Copy shIn.Cells(iRow + 7, 2) 'Налоги
shOut.Range("B18:M18").Copy shIn.Cells(iRow + 14, 2) 'объем отгрузок
shOut.Range("B20:M20").Copy shIn.Cells(iRow + 16, 2) 'Расходы на обслуживание
importWB.Close False 'закрываем файлы без сохранения
Next x
Application.EnableEvents = True
Application.ScreenUpdating = True
With Sheets("Список компаний")
.Select ' преход на главный лист, ели это теперь надо, ведь код больше не "прыгает" по листам и книгам
.Range("C1").Value = VBA.Date ' Date - возвращает текущую дату или можете конкретно указать #3/15/2018#
End With
MsgBox ("Файлов скопированно - " & UBound(FilesToOpen)) ' вывод сколько файлов скопированно
End Sub
Function SplitFileName(sFullPath As String)
'получить имя файла без расширения
Dim str() As String, temp As String
str = Split(sFullPath, Application.PathSeparator)
temp = str(UBound(str))
str = Split(temp, ".")
SplitFileName = Mid(temp, 1, Len(temp) - Len(str(UBound(str))) - 1)
End Function
Кстати, в обрабатываемой книге "СиЭс Медика Тюмень.xls" есть макрос Workbook_BeforeClose, где вы генерируете путь и имя файла, s2 = s2 & "/" & sv
так вот слэш, который вы используете, в Винде имеет наклон в другую сторону, но если в Маке, то все верно.
Что бы код работал и в Винде, и в Маке используйте Application.PathSeparator
boa, Спасибо за код!
Set shIn = ThisWorkbook.Sheets(ListName) - здесь выдает ошибку.
Пробовал на компании СиЭс Медика ТехЭксперт Северо-Запад, подозреваю, что макрос данный лист не находит, так как весь текст названия компании в название листа не вмещается.
Вмещается только СиЭс Медика ТехЭксперт Северо-. поэтому выпадает ошибка 9. Можно как то исправить, или есть другие варианты ввода кода
Да и еще при выборе файла на открытие выводит сообщение
Ограничение Excel - название листа 31 символ.
Поэтому если ListName > 31, то вы его в книге, конечно, не найдете и получите ошибку.
можно обрезать ListName функцией mid
например:
ListName = Mid(SplitFileName(CStr(x)), 1, 31)
ну и соответственно лист с таким именем должен быть.
для "СиЭс Медика ТехЭксперт Северо-Запад", это будет "СиЭс Медика ТехЭксперт Северо-З"
По поводу ошибки прерывания кода не могу сказать что-то конкретное,
покажите код после нажатия кнопки ""Debug",
укажите версию и разрядность операционной системы и Excel.
boa, еще раз спасибо, после вашего кода все заработало как нужно и ошибка прерывания кода пропала ;D