Скопируйте указанный c диапазон из нескольких книг на один лист

Question

Я пытаюсь сделать что-то похожее на то, что задается в вопросе для VBA: скопируйте указанный c диапазон из нескольких книг в один лист , но с небольшими отклонениями. Я пытаюсь получить значение одной ячейки (AB26) из нескольких книг и объединить их в одну основную книгу в одном столбце. Вот с чем я работаю с точки зрения кода:

Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Const strPath As String = "\\OTLAN1\USERDATA\BCAS\CTCAC\2020\2020 E-Apps\Old E-Apps\"
ChDir strPath
strExtension = Dir("*.xls*")
Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
    With wkbSource
    'locate last row to start copying new value from the next spreadsheet
        LastRow = .Sheets("Basis & Credits").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'From the Basis & Credits cell AB46, copy to last row+1 in the Master sheet starting in row A2
        .Sheets("Basis & Credits").Range("AB46" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        .Close savechanges:=False
    End With
    strExtension = Dir
Loop
Application.ScreenUpdating = True End Sub

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

Answer 1

Если вам нужно скопировать из AB26, попробуйте следующий код, пожалуйста:

Sub CopyRange()
Application.ScreenUpdating = False
Dim wkbDest As Workbook, sh As Worksheet
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long

strExtension = Dir(strPath & "*.xls*")
Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strPath & strExtension)
    With wkbSource
       'locate last row to start copying new value from the next spreadsheet
        LastRow = wkbDest.Sheets("Master").Cells(Rows.count, "A").End(xlUp).Offset(1, 0).row
        'From the Basis & Credits cell AB46, copy to last row+1 in the Master sheet starting in row A2
        .Sheets("Basis & Credits").Range("AB26").Copy wkbDest.Sheets("Master").Range("A" & LastRow)
        .Close savechanges:=False
    End With
    strExtension = Dir
Loop
Application.ScreenUpdating = True
End Sub

Но если вам нужно скопировать из «AB46», как написано в комментарии к коду, вы, конечно, должны , замените Range("AB26").Copy на Range("AB46").Copy ...

Answer 2

Я думаю, ваша проблема в этой строке

.Sheets("Basis & Credits").Range("AB46" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Измените диапазон для копирования с Range("AB46" & LastRow) на Range("AB" & LastRow), т.е. удалите 46, и строка станет

.Sheets("Basis & Credits").Range("AB" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

Я подозреваю, что вы сейчас копируете ячейку AB4626, которая, скорее всего, пуста.