Время выполнения 1004: метод «Диапазон» объекта «Рабочий лист» завершился ошибкой при вставке - PullRequest
0 голосов
/ 10 мая 2019

Мой код будет перебирать все файлы в папке и копировать информацию в выбранные ячейки из листа «Форма менеджера» в мастер-файл.Когда я хочу добавить дополнительные диапазоны для копирования, он блокирует меня с ошибкой.

Проблема с этой строкой:
NewSht.Range ("B" & PasteRow) .PasteSpecial xlPasteValues ​​

Как мне указать диапазон для вставки?

Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb  As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim OldSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long

' set master workbook
Set Masterwb = Workbooks("result2.xlsm")

folderPath = "C:\Users\Downloads\Tech\TimeSheets2019\inside" 'contains folder path

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False

Filename = Dir(folderPath & "*.xlsx*")
Do While Filename <> ""
    Set wb = Workbooks.Open(folderPath & Filename, ReadOnly:=True)
    Set NewSht = Masterwb.Worksheets("Tabelle1") ' added
    Set OldSht = wb.Worksheets("Manager Form") ' added

    ' get the first empty row in the new sheet
        Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)

        If Not FindRng Is Nothing Then ' If find is successful
            PasteRow = FindRng.Row + 1
        Else ' find was unsuccessfull > new empty sheet, should paste at the first row
            PasteRow = 1
        End If

        OldSht.Range("B7").Copy

        NewSht.Range("B" & PasteRow).PasteSpecial xlPasteValues

    wb.Close False

1 Ответ

0 голосов
/ 10 мая 2019
' get the first empty row in the new sheet
 Dim target as range
 Set target = newsht.cells(NewSht.usedrange.rows.count +1,2)

OR

 Dim target as Range
 Set target = newsht.cells(newsht.rows.count,2).end(xlup).offset(1,0)

Тогда

  target.formula = OldSht.Range("B7").value  'copy value into blank cell
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...