Copying data from multiple worksheets into new worksheet

[PWSY86]

Hi,


I need to collect data (selected range) from multiple worksheets in to new one. I used this code

Sub AppendDataAfterLastColumn()    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    'Delete the sheet "MergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    'Add a worksheet with the name "MergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "MergeSheet"


    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Sheets(Array("Sheet1", "Sheet2"))
    
            'Find the last Column with data on the DestSh
            Last = LastCol(DestSh)


            'Fill in the column(s) that you want to copy
            Set CopyRng = sh.Range("A:C")


            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Columns.Count > DestSh.Columns.Count Then
                MsgBox "There are not enough columns in the Destsh"
                GoTo ExitTheSub
            End If


            'This example copies values/formats and Column width
            CopyRng.Copy
            With DestSh.Cells(1, Last + 1)
                
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With


        
    Next


ExitTheSub:


    Application.Goto DestSh.Cells(1)


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

I want to have data from column A,B and C from Sheet1 and Sheet2 in the same columns in MergeSheet.

any help?

 

[JLGWhiz]

Disregard

 

[PWSY86]

After change code an error occured:

run-time error 1004

We can't paste because the Copy area and paste area aren't the same size.

And this lines are highlighted

 .PasteSpecial 8    ' Column width                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats

 

[PWSY86]

i deleted this line

 .PasteSpecial 8    ' Column width

new error is

PasteSpecial method of Range class failed


other thing is how to set destination cells auto adjust to copied data?

 

[JLGWhiz]

Had to rewrite a lot of it.

Sub AppendDataAfterLastRow()
Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Delete the sheet "MergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("MergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Add a worksheet with the name "MergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "MergeSheet"
    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Sheets(Array("Sheet1", "Sheet2"))
            'Find the last Row with data on the Source Sheet
            LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            'Fill in the column(s) that you want to copy
            Set CopyRng = sh.Range("A1:C" & LastRow)
            'Test if there enough rows in the DestSh to copy all the data
            With DestSh
                If (.Rows.Count - .Cells(Rows.Count, 1).End(xlUp).Row) < LastRow Then
                    MsgBox "There are not enough Rows in the Destsh"
                    GoTo ExitTheSub
                End If
            'This example copies values/formats and Column width
            CopyRng.Copy
            With DestSh.Cells(Rows.Count, 1).End(xlUp)(2)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Test this to see if I got it right.

 

[PWSY86]

many thanks for your time...

now there's compile error: Argument not optional and this part of code is highlighted

LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row

 

[Peter_SSs]

Welcome to the MrExcel board!

I want to have data from column A,B and C from Sheet1 and Sheet2 in the same columns in MergeSheet.

Could you clarify exactly what you mean by that?

After change code an error occured:

run-time error 1004

We can't paste because the Copy area and paste area aren't the same size.

And this lines are highlighted

 .PasteSpecial 8    ' Column width                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats

After what change of code?
This line of code does not appear in your original code and by itself means nothing.

other thing is how to set destination cells auto adjust to copied data?

Could you clarify exactly what you mean by that?

 

[PWSY86]

Welcome to the MrExcel board!


Could you clarify exactly what you mean by that?

Data from column A in Sheet1 and column A in Sheet2 will be copied to column A in MergeSheet - same for other columns.

After what change of code?
This line of code does not appear in your original code and by itself means nothing.

My mistake, it was originally in my code but I deleted it before posting.
It was written

CopyRng.Copy            With Destsh.Cells(Last + 1, "A")
                .PasteSpecial 8 'Column width
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

Could you clarify exactly what you mean by that?

I want dimensions of destination cell be the same as copied one.

 

[JLGWhiz]

many thanks for your time...

now there's compile error: Argument not optional and this part of code is highlighted

LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row

I cannot get the error to duplicate. Make sure there are no symbols or spaces included on that line by copying the text, deleting the line and then re-pasting the line back in. Also change this:

Dim Last As Long

To this

Dim LastRow As Long

 

[Peter_SSs]

now there's compile error: Argument not optional and this part of code is highlighted

LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row

I don't get that error but I do wonder why the Find is looking in xlFormulas, not xlValues?
That could result in finding a LastRow that is well below the last actual data in the worksheet.

Also, as far as I understand it, we are copying columns A:C to another sheet but we don't know if there are more than 3 columns used in Sheet1 and/or Sheet2. If that is the case then this 'Find' in any case might return a row well below the last actual data in columns A:C. For that reason I think this line would be better as

sh.Columns("A:C").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

Back to the error: I do get an error with the given code, but it is because there is a missing 'End With', which I believe should be here:

'Test if there enough rows in the DestSh to copy all the data
With DestSh
    If (.Rows.Count - .Cells(Rows.Count, 1).End(xlUp).Row) < LastRow Then
        MsgBox "There are not enough Rows in the Destsh"
        GoTo ExitTheSub
    End If
End With
'This example copies values/formats and Column width
CopyRng.Copy

I want dimensions of destination cell be the same as copied one.

That could be tricky. All the cells in a column must be the same width.
If column A in Sheet1 is 20 wide and column A in Sheet2 is 30 wide, we can't have some cells in column A of 'MergeSheet' 20 wide and some 30 wide.
Row height is a different matter.
Can you clarify what your real need is in terms of cell "dimension"?