Профессиональные приемы работы в Microsoft Excel

Обмен опытом => Microsoft Excel => Тема начата: Владимир Попов от 13.03.2018, 16:28

Название: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: Владимир Попов от 13.03.2018, 16:28
Нужна Ваша помощь ???. допилить макрос. Суть макроса следующая: Присланные от регионов файла хранятся в одной папке. Файл имеет название  такое же как и компания (в сводном файле это столбец В). Данные файлы необходимо скопировать в сводный файл (Service ФХД_Сводная) в лист той компании, как называется присланный от компании файл, т.е. с название компании. Копирование на данный момент происходит, начиная с ячейки В 142 каждого вложенного файла в сводный. В итоге хотелось бы получить от макроса открытие всех файлов в папке присланных регионами и копирование их в сводный файл в лист с одинаковым названием.

Прописал макрос путем проб и ошибок, файл в приложении. Может не работать из-за расширения открываемых листов. Вопрос к знающим людям: если листы которые присылают регионы имеют разное расширение, допустим: .xlsm и .xls или .xlsx Как прописать в макросе открытие листов с разным расширением? 
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: boa от 18.03.2018, 13:15
можете получать имя листа отрезав от имени файла расширение

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
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: boa от 18.03.2018, 16:20
Ваш код я переписал и сохранил в модуле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
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: Владимир Попов от 19.03.2018, 09:54
boa, Спасибо за код!
Set shIn = ThisWorkbook.Sheets(ListName) - здесь выдает ошибку.
Пробовал на компании СиЭс Медика ТехЭксперт Северо-Запад, подозреваю, что макрос данный лист не находит, так как весь текст названия компании в название листа не вмещается.
Вмещается только СиЭс Медика ТехЭксперт Северо-. поэтому выпадает ошибка 9. Можно как то исправить, или есть другие варианты ввода кода
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: Владимир Попов от 19.03.2018, 10:44
Да и еще при выборе файла на открытие выводит сообщение
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: boa от 19.03.2018, 13:33
Ограничение Excel - название листа 31 символ.
Поэтому если ListName > 31, то вы его в книге, конечно, не найдете и получите ошибку.
можно обрезать ListName функцией mid
например:

ListName = Mid(SplitFileName(CStr(x)), 1, 31)

ну и соответственно лист с таким именем должен быть.
для "СиЭс Медика ТехЭксперт Северо-Запад", это будет "СиЭс Медика ТехЭксперт Северо-З"

По поводу ошибки прерывания кода не могу сказать что-то конкретное,
покажите код после нажатия кнопки ""Debug",
укажите версию и разрядность операционной системы и Excel.
Название: Re: Копирование данных из нескольких файлов в сводный файл в определенный лист
Отправлено: Владимир Попов от 20.03.2018, 10:04
boa, еще раз спасибо, после вашего кода все заработало как нужно и ошибка прерывания кода пропала ;D