Новости:

К первому сообщению темы должен быть прикреплен файл примера в формате xls*.
Приложив пример, Вы избавите себя и других от вопросов типа "А какой критерий?", "А куда выводить результат?", "А сколько строк?" и все тех же просьб выложить файл. Рисовать за Вас Ваши же таблички с заданиями, а затем и решение к ним, никто желанием не горит. Да и, как показывает практика, в большинстве случаев без файла решения не найти.

Главное меню

Копирование данных из нескольких файлов в сводный файл в определенный лист

Автор Владимир Попов, 13.03.2018, 16:28

« назад - далее »

Владимир Попов

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

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

boa

можете получать имя листа отрезав от имени файла расширение

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
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

boa

Ваш код я переписал и сохранил в модуле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. Можно как то исправить, или есть другие варианты ввода кода

Владимир Попов

Да и еще при выборе файла на открытие выводит сообщение

boa

Ограничение Excel - название листа 31 символ.
Поэтому если ListName > 31, то вы его в книге, конечно, не найдете и получите ошибку.
можно обрезать ListName функцией mid
например:

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

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

По поводу ошибки прерывания кода не могу сказать что-то конкретное,
покажите код после нажатия кнопки ""Debug",
укажите версию и разрядность операционной системы и Excel.
Ничто не обходится нам так дешево и не ценится так дорого, как вежливость...  Мигель Сервантес де Сааведра

Владимир Попов

boa, еще раз спасибо, после вашего кода все заработало как нужно и ошибка прерывания кода пропала ;D