Excel VBA - Попытка скопировать 300 диапазонов рабочих книг в лист на основе списка пакетных файлов и получение сообщения об ошибке «Не удалось выполнить метод Pastespecial класса диапазона» - PullRequest
1 голос
/ 05 апреля 2019

Мой код работает, как показано ниже, но в зависимости от количества рабочих книг, с которыми я сталкиваюсь, возникает ошибка Pastespecial method of range class failed. Ошибка произошла где-то от 3 рабочих книг, импортирующих до самого высокого, который я получил в тестах до сих пор - 240/300. Это началось довольно неплохо, но сейчас мне повезло с большим выбором повторяющегося кода, описанного ниже.

Вот некоторые ключевые компоненты того, что я делаю:

  1. В комбинированном рабочем листе есть кнопка макроса на вкладке «Входы»
  2. На вкладке «Входы» указаны диапазоны, в которые необходимо скопировать конкретный лист на лист «data1»
  3. 'calc_page' имеет список путей импорта, которые могут изменяться в зависимости от того, в какой папке находится рабочая книга. Они ссылаются на связанные пути рабочей книги, которые я хотел бы импортировать в диапазоны, указанные в компоненте 2

Вот основные шаги, которые я хочу выполнить:

  1. Открыть рабочую книгу, скопировать определенный диапазон из этой ссылки на рабочую книгу с косвенным
  2. Вставить данные рабочей книги в указанный диапазон на листе «data1» [это изменяется в зависимости от того, какой диапазон у меня в списке]
  3. Очистить буфер обмена и выйти из рабочей книги
  4. Запустить процесс для следующего файла в диапазоне

Я перепробовал несколько сценариев в стеке с аналогичными результатами.

Поскольку это длительный процесс, я вызываю список других макросов, настроенных аналогичным образом. Я сократил код ниже, но у каждого макроса есть около 45 непосредственно закодированных ссылок.

Sub ImportDataFromList()
    Dim App As New Excel.Application 'create new hidden Excel window

    ' Assign active sheet for copying
    Dim wsActive As Worksheet
    Set wsActive = Sheets("data1")

    'Open designated file in new Excel window as read only
    Dim wbImport As Workbook

    Set wbImport = App.Workbooks.Open(Filename:=Worksheets("calc_page").Range("C5"), UpdateLinks:=True, ReadOnly:=True)
    Set wsActive = Sheets("data1")
    'Copy the data to active sheet
    wbImport.Worksheets("Sheet1").Range("A1:N125").Copy
    wsActive.Range([indirect("P5")]).PasteSpecial xlPasteValues  
    App.CutCopyMode = False 'Clears clipboard
    wbImport.Close SaveChanges:=False 'Close new Excel window without saving
    App.Quit 'Quit new Excel window

    Application.Wait (Now + TimeValue("00:00:01"))


    Set wbImport = App.Workbooks.Open(Filename:=Worksheets("calc_page").Range("C6"), UpdateLinks:=True, ReadOnly:=True)
    Set wsActive = Sheets("data1")
    'Copy the data to active sheet
    wbImport.Worksheets("Sheet1").Range("A1:AJ74").Copy
    wsActive.Range([indirect("P6")]).PasteSpecial xlPasteValues  
    App.CutCopyMode = False 'Clears clipboard
    wbImport.Close SaveChanges:=False 'Close new Excel window without saving
    App.Quit 'Quit new Excel window

    Application.Wait (Now + TimeValue("00:00:01"))
End Sub

Я хочу, чтобы он мог запускаться из конца в конец без специальной ошибки и успешно импортировать все значения открытого текста из этого списка рабочих книг. Действительно ценю любые рекомендации или даже потенциальные идеи о том, как я могу заставить это работать. Спасибо!

1 Ответ

0 голосов
/ 05 апреля 2019

Добро пожаловать на SO. Не удалось понять, почему приложение New Excel используется для открытия исходных файлов. Настройка Application.ScreenUpdating = False может быть легко использована, чтобы сделать исходный файл практически невидимым. Цель приложения Ожидание также неясно

Пробовал несколько раз с измененным кодом для 300 циклов и диапазоном данных около 250 X 15 ячеек (с повторным открытием и закрытием только одного исходного файла для ознакомительной цели) и занимает всего около 3 минут для успешного завершения задачи.

Sub ImportDataFromList()
Dim wsActive As Worksheet
Dim wbImport As Workbook
Dim wsCalc As Worksheet
Dim Fname As String, Rw As Long, sSht As String, sRng As String, Trng As String
Dim srcRng As Range, TrgRng As Range
'Dim Tm As Double

Set wsActive = ThisWorkbook.Sheets("data1")
Set wsCalc = ThisWorkbook.Sheets("calc_page")
'Tm = MicroTimer()

Application.ScreenUpdating = False
For Rw = 5 To 305
Fname = wsCalc.Range("C" & Rw) ' Source File Name4
sSht = wsCalc.Range("D" & Rw)  ' Source Sheet name
sRng = wsCalc.Range("E" & Rw)  ' Source Range
Trng = wsCalc.Range("F" & Rw)  ' Target Range.(Only Top Left cell address is used for trial. later resized to the source range)

Set wbImport = Workbooks.Open(Filename:=Fname, UpdateLinks:=True, ReadOnly:=True)
Set srcRng = wbImport.Worksheets(sSht).Range(sRng)
Set TrgRng = wsActive.Range(Trng)
Set TrgRng = TrgRng.Resize(srcRng.Rows.Count, srcRng.Columns.Count)
TrgRng.Cells.Value = srcRng.Cells.Value
wbImport.Close SaveChanges:=False
Next

'Tm = MicroTimer() - Tm
Application.ScreenUpdating = True
'Debug.Print Tm
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...