Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос копирования данных с разных книг в одну
 

Добрый день.

Использую уже достаточно давно найденный на форуме макрос для копирования данных с нескольких книг в одну по критерию соответствия названия листов в сводной книге и названий исходных книг.

Код
 Private Sub Workbook_Open()
   Dim ws As Worksheet, myPath As String, myName As String, s As String, wb As Object, fso
      
   Application.ScreenUpdating = False
  
   myPath = "путь к папке хранения"
      
   For Each ws In Sheets
       myName = Dir(myPath & "*.xls")
       Do While myName <> ""
           If Left(myName, Len(myName) - 4) = ws.Name Then
               Set wb = Workbooks.Open(myPath & myName)
               wb.Sheets(1).Cells.Copy ws.[a1]
               wb.Close False
           End If
           myName = Dir
       Loop
   Next
End Sub

Все работало хорошо до тех пор, пока не изменился формат исходных книг (с «xls» на «xlsx» и «xlsn»).

Попробовал поменять в коде на xsl*, но это не помогло.

Подскажите, пожалуйста, можно ли поправить код, чтобы он тянул информацию с новых форматов?

Пример прилагаю.

 
Код
myName = Dir(myPath & "*.xls*")
       Do While myName <> ""
           If Left(myName, Len(myName) - 5) = ws.Name Then
               Set wb = Workbooks.Open(myPath & myName)
               wb.Sheets(1).Cells.Copy ws.[a1]
               wb.Close False
           End If
           myName = Dir
       Loop
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Большое спасибо! Все заработало.
 
Прошу прощения за свою огромную наглость, но не могли бы еще подсказать как настроить копирование только значениями?
 
PetyaA, попробуйте
Код
wb.Sheets(1).Cells.Copy
With ws.Range("A1")
    .PasteSpecial Paste:=xlPasteColumnWidths 'сохраняем ширину столбцов источника
    .PasteSpecial Paste:=xlPasteFormats 'сохраняем форматирование источника
    .PasteSpecial Paste:=xlPasteValues 'вставляем только значения (формулы также преобразовываются в их значения)
End With
Application.CutCopyMode = False
поэкспериментируйте с параметрами вставки. Вам нужен только последний…
Изменено: Jack Famous - 3 Апр 2018 17:59:27
«Тот, кто несет фонарь, спотыкается чаще, чем тот, кто идет следом.»
Иоганн Пауль Фридрих Рихтер
 
Спасибо, Jack Famous.
Что-то, видимо, пошло не так.
Выскакивает ошибка "Run time error '1004': Для этого все ячейки должны иметь одинаковый размер".
Правильно ли я понимаю, что Ваш вариант предполагает, что в исходных файлах не должно быть объединенных ячеек?
 
Код
arr=wb.Sheets(1).usedrange.value
ws.[a1].resize(ubound(arr,1),ubound(arr,2))=arr

Для массивов объединенные ячейки не преграда)

Изменено: Anchoret - 3 Апр 2018 18:18:52
 
Цитата
PetyaA написал:
Ваш вариант предполагает
ничего он не предполагает)) вы спросили, как вставить только значения - я показал один из вариантов + парочку методов специальной вставки для расширения кругозора  :)
При копировании всего листа на вновь созданный, никаких проблем с объединёнными ячейками быть не должно.
Изменено: Jack Famous - 3 Апр 2018 18:33:44
«Тот, кто несет фонарь, спотыкается чаще, чем тот, кто идет следом.»
Иоганн Пауль Фридрих Рихтер
 
Anchoret, не могли бы уточнить, пожалуйста.
Вашим кодом необходимо заменить вот эту часть:
Код
wb.Sheets(1).Cells.Copy ws.[a1]
wb.Close False
         или я что-то не так понял
 
PetyaA, вставить между строками. Логика и действия: полностью копируем содержимое листа и вставляем на другой лист, место ставки [A1] (верхний левый угол), далее мои пара строк формируют массив из значений всех ячеек листа-источника и далее выгрузка этого массива на лист-приемник с заменой всех формул и прочего на значения. Вместо ресайза можно данные передать следующим образом:
Код
ws.usedrange.value=arr

Если нужно только передать содержимое ячеек без форматов, объединенных ячеек и прочего, то можно заменить.

Изменено: Anchoret - 3 Апр 2018 21:05:51
 
Тогда наверное, правильнее будет начинать вставку не с А1, а с той, которая действительно первая в исходном листе:
Код
Do While myName <> ""
           If Left(myName, Len(myName) - 5) = ws.Name Then
               Set wb = Workbooks.Open(myPath & myName)
               arr=wb.Sheets(1).usedrange.value
               ws.Range(wb.Sheets(1).usedrange.Cells(1,1).Address).resize(ubound(arr,1),ubound(arr,2))=arr
               wb.Close False
           End If
           myName = Dir
       Loop
Т.к. UsedRange далеко не всегда с первой ячейки стартует...
Хотя я все же склонялся бы к PasteSpecial - вариант через массивы при больших объемах данных на листах может выбить в ошибку переполнения памяти(от ПК зависит, да от других параметров).
Я бы все же делал так, как советовали изначально:
Код
Do While myName <> ""
           If Left(myName, Len(myName) - 5) = ws.Name Then
               Set wb = Workbooks.Open(myPath & myName)
               wb.Sheets(1).Cells.Copy
               ws.Range("A1").PasteSpecial xlPasteValues
               ws.Range("A1").PasteSpecial xlPasteColumnWidths
               ws.Range("A1").PasteSpecial xlPasteFormats
               wb.Close False
           End If
           myName = Dir
       Loop
Изменено: Дмитрий Щербаков - 3 Апр 2018 21:14:20
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Всем огромное спасибо за помощь!
Оба варианта в моей комбинации файлов сработали на ура.
Страницы: 1
Читают тему (гостей: 1)
Наверх