CODEWITHSUNDEEP
arraysexcelrangevba
Darkcloud617
Darkcloud617

Reputation: 35

Copying and pasting data between workbooks in an array of sheets

I am lost and have tried to find this specific issue on multiple forums and cannot seem to piece it together. Very quick question hopefully. This code is meant to:

The problem I have is that maybe usedrange.copy is copying all data from the 5 workbooks strangely. It does not seem to copy ALL of the data (maybe counting column A to find last used row and copying based on that?).

Is there a different way of achieving what I am needing to do? I thought it would be easier because it is just copying all data from the 5 sheets and pasting in a different wkbk... but... nay. Any help is greatly appreciated.

    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

Upvotes: 1

Views: 1570

Answers (3)

Rachel Hettinger
Rachel Hettinger

Reputation: 8442

This code finds the correct place to paste the data so nothing is lost or overwritten (e.g. first row with no data in columns 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

Note: I removed unnecessary code; for explanations, see previous answers.

Upvotes: 1

chris neilsen
chris neilsen

Reputation: 53126

That extra .End(xlUp) is what is causing your issues. (Even though you said you removed it in a comment, it's still in your sample files)

Here's your code refactored, including some other minor issues addressed, and inline comments (marked with <--- on what I changed

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

Upvotes: 0

kolcinx
kolcinx

Reputation: 2233

Try this gem: cells.SpecialCells(xlCellTypeLastCell)
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-specialcells-method-excel

Try something along these lines:

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

Upvotes: 0

Related Questions