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

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Читайте новые сообщения форума форума в RRS-агрегаторах

Автор Тема: Копирование данных из нескольких файлов в сводный файл в определенный лист  (Прочитано 628 раз)

0 Пользователей и 1 Гость просматривают эту тему.

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

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

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

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

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 533
  • Доброта спасет мир...

можете получать имя листа отрезав от имени файла расширение
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

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 533
  • Доброта спасет мир...

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

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

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

boa, Спасибо за код!
Set shIn = ThisWorkbook.Sheets(ListName) - здесь выдает ошибку.
Пробовал на компании СиЭс Медика ТехЭксперт Северо-Запад, подозреваю, что макрос данный лист не находит, так как весь текст названия компании в название листа не вмещается.
Вмещается только СиЭс Медика ТехЭксперт Северо-. поэтому выпадает ошибка 9. Можно как то исправить, или есть другие варианты ввода кода
Записан

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

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

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

boa

  • Глобальный модератор
  • Старожил
  • *****
  • Уважение: +31/-0
  • Оффлайн Оффлайн
  • Сообщений: 533
  • Доброта спасет мир...

Ограничение Excel - название листа 31 символ.
Поэтому если ListName > 31, то вы его в книге, конечно, не найдете и получите ошибку.
можно обрезать ListName функцией mid
например:
ListName = Mid(SplitFileName(CStr(x)), 1, 31)
ну и соответственно лист с таким именем должен быть.
для "СиЭс Медика ТехЭксперт Северо-Запад", это будет "СиЭс Медика ТехЭксперт Северо-З"

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

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

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 10

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



Темы без ответов

30.09.2018 10:24 Расчет процентов за определенный период (месяц) с учетом изменений и платежей 151
22.05.2018 11:38 Скрипт написать который допишет данные в файл 712
03.03.2018 00:00 Подсчет отработанного времени, за исключением заранее определенных перерывов 952
14.02.2018 10:11 Подготовить читабельную отчетность по платежам 930
23.01.2018 13:46 Найти вероятность повторной покупки 878
12.01.2018 23:56 Сделать отчет на Power BI (Dashboard) 1212
06.09.2017 10:43 Solver VBA не решает гиперболическое уравнение, но при этом решает гармоническое 1126
17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 1461
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 3134
15.03.2017 15:45 автозамена картинок PowerPoint 1846





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.157 секунд. Запросов: 113.