Копирование и вставка данных между книгами в массив листов

Question

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

• Поиск последней ячейки, содержащей данные в 5 листах. Он должен искать данные, отличные от столбца «A» или «B», поскольку они могут быть или не быть пустыми.
• повторить для всех 5 листов в массиве
• Вставьте все данные из 5 листов в исходную рабочую книгу в «Лист 4» один за другим

У меня проблема в том, что может быть, usedrange.copy странным образом копирует все данные из 5 рабочих книг. Кажется, он не копирует ВСЕ данные (возможно, считая столбец A, чтобы найти последнюю использованную строку и копируя на основании этого?).

Есть ли другой способ достижения того, что мне нужно сделать? Я думал, что это будет проще, потому что это просто копирование всех данных с 5 листов и вставка в другой wkbk ... но ... нет. Любая помощь с благодарностью.

    Sub Notes2()
'Last row in column
Dim WS As Worksheet, shAry As Variant, i As Long
Dim AOFF As Range
Dim rOWIS As Integer
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
Set WS = Worksheets("Sheet 4")
With WS
    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    LastCellRowNumber = LastCell.Row + 1
End With
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(vFile)
With wb2
    shAry = Array(.Sheets("Week 1"), .Sheets("Week 2"), .Sheets("Week 3"), .Sheets("Week 4"), .Sheets("Over 30"))
End With
    For i = LBound(shAry) To UBound(shAry)
        shAry(i).UsedRange.Copy
        wb.Activate
        WS.Cells(Rows.Count, 3).End(xlUp).End(xlUp)(2).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    Next
Application.ScreenUpdating = True
'Close
wb2.Close False
End Sub

Answer 1

Эта дополнительная .End(xlUp) является причиной ваших проблем. (Даже если вы сказали, что удалили его в комментарии, он все еще находится в ваших примерах файлов)

Вот ваш рефакторинг кода, включая некоторые другие устраненные мелкие проблемы и встроенные комментарии (помеченные <--- в том, что я изменил

Sub Notes2()
    'Last row in column
    Dim ws As Worksheet, shAry As Variant, i As Long
    Dim AOFF As Range
    Dim rOWIS As Long              ' <-- better to use long
    Dim wb As Workbook, wb2 As Workbook
    Dim vFile As Variant
    Dim LastCell As Range          ' <-- Define all variables
    Dim LastCellRowNumber As Long  ' <--
    'Set source workbook
    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets("Sheet 4") ' <-- specify context
    'With ws                          ' <--- not used in rest of code
    '    Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
    '    LastCellRowNumber = LastCell.Row + 1
    'End With
    'Open the target workbook
    vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
        1, "Select File To Open", , False)
    'if the user didn't select a file, exit sub
    If vFile = False Then Exit Sub   ' <--  simpler
    Application.ScreenUpdating = False
    Set wb2 = Workbooks.Open(vFile)
    With wb2
        shAry = Array(.Sheets("Week 1"), .Sheets("Week 2"), .Sheets("Week 3"), .Sheets("Week 4"), .Sheets("Over 30"))
    End With
    For i = LBound(shAry) To UBound(shAry)
        shAry(i).UsedRange.Copy
        'wb.Activate                 ' <--- not needed
        ws.Cells(ws.Rows.Count, 3).End(xlUp)(2).PasteSpecial xlPasteValues ' <-- specify ws, remove extra End
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
    'Close
    wb2.Close False
End Sub

Answer 2

Этот код находит правильное место для вставки данных, чтобы ничего не было потеряно или перезаписано (например, первая строка без данных в столбцах C:).

Sub Rectangle1_Click()

Dim WS As Worksheet
Dim wb2 As Workbook
Dim vFile As Variant
Dim shAry As Variant
Dim sh As Variant

Set WS = ActiveWorkbook.Worksheets("Sheet 1")

'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(vFile)

With wb2
    shAry = Array(.Sheets("Week 1"), .Sheets("Week 2"), .Sheets("Week 3"), .Sheets("Week 4"), .Sheets("Over 30"))
End With
For Each sh In shAry
    Dim LastCell As Range
    Set LastCell = WS.Range("C:O").Find(What:="*", SearchDirection:=xlPrevious)
    If LastCell Is Nothing Then Set LastCell = WS.Range("C1")
    Range(sh.Cells(1, 1), sh.Cells.SpecialCells(xlCellTypeLastCell)).Copy
    WS.Cells(LastCell.Row + 1, 3).PasteSpecial xlPasteValues
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True
wb2.Close False
End Sub

Примечание: я удалил ненужный код; объяснения см. в предыдущих ответах.

Answer 3

Попробуйте этот камень: cells.SpecialCells(xlCellTypeLastCell)
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-specialcells-method-excel

Попробуйте что-нибудь в этом духе:

Dim sh as Variant

For Each sh In shAry
    Range(sh.cells(1,1),sh.cells.SpecialCells(xlCellTypeLastCell)).Copy
    'wb.Activate 'Leave out. Dont need this.
    WS.Cells(Rows.Count, 3).End(xlUp).End(xlUp)(2).PasteSpecial xlPasteValues
    'Application.CutCopyMode = False 'If you really need this, put it after loop.
Next

Application.CutCopyMode = False