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]

The only change I made to this was to move the End With up to where it belonged and re-indent the code so it made sense. I cannot duplicate the error you are getting. It appears to work as intended.

Sub KopiaDanychDoNowegoArkusza()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LastRow As Long
    Dim CopyRng As Range
    Dim DZNextRow As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Usuwa 'Dane Zbiorcze' jesli istnieje
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Dane Zbiorcze").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Dodaje arkusz 'Dane Zbiorcze'
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Dane Zbiorcze"
    'Dodaje naglówki w pierwszym rzedzie
    With DestSh
        .Cells(1, 1).Value = "Nazwa Kina"
        .Cells(1, 2).Value = "Siec"
        .Cells(1, 3).Value = "Miasto"
        .Cells(1, 4).Value = "Województwo"
    End With
        ' zamraza pierwszy rzad
        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With
        If Not ActiveSheet.AutoFilterMode Then
            ActiveSheet.Range("A1").AutoFilter
        End If
        'zapetla przez wybrane skoroszyty i kopiuje dane do DestSh
        For Each sh In ActiveWorkbook.Worksheets
            If sh.Name <> DestSh.Name Then
                'Znajduje ostatni wiersz z danymi w arkuszach zródlowych
                LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
                'uzupelnia kolumne które maja byc skopiowane
                Set CopyRng = sh.Range("A2:D" & LastRow)
                'Sprawdza czy jest wystarczajaca ilosc wierszy w DestSh do skopiowania danych
                With DestSh
                    'Find next blank row at bottom of sheet
                    DZNextRow = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
                    If DZNextRow + LastRow > .Rows.Count Then
                        MsgBox "There are not enough Rows in the Destsh"
                        GoTo ExitTheSub
                    End If
                End With
                'kopiuje wartosci/formaty komórek
                CopyRng.Copy
                With DestSh.Cells(DZNextRow, 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            Application.ScreenUpdating = False
            ActiveSheet.Columns.AutoFit
        End If
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Peter_SSs]

My guess is that the error is this line, and the problem will be because you have a blank worksheet, so the 'Find' would fail. Is that the case?
If not, what line causes the error message?

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

 

[PWSY86]

My guess is that the error is this line, and the problem will be because you have a blank worksheet, so the 'Find' would fail. Is that the case?
If not, what line causes the error message?

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

I'm really green with VB, but isn't this code line refering to source sheets?

When I debug this code line by line, error shows when i get to this part:

ExitTheSub:    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

until I get there all commands work.

 

[PWSY86]

in first version of code with source sheets selected by array it works flawless, but since I changed it to treat all sheets as source error occured.

 

[PWSY86]

The only change I made to this was to move the End With up to where it belonged and re-indent the code so it made sense. I cannot duplicate the error you are getting. It appears to work as intended.

Sub KopiaDanychDoNowegoArkusza()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LastRow As Long
    Dim CopyRng As Range
    Dim DZNextRow As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Usuwa 'Dane Zbiorcze' jesli istnieje
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Dane Zbiorcze").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Dodaje arkusz 'Dane Zbiorcze'
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Dane Zbiorcze"
    'Dodaje naglówki w pierwszym rzedzie
    With DestSh
        .Cells(1, 1).Value = "Nazwa Kina"
        .Cells(1, 2).Value = "Siec"
        .Cells(1, 3).Value = "Miasto"
        .Cells(1, 4).Value = "Województwo"
    End With
        ' zamraza pierwszy rzad
        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With
        If Not ActiveSheet.AutoFilterMode Then
            ActiveSheet.Range("A1").AutoFilter
        End If
        'zapetla przez wybrane skoroszyty i kopiuje dane do DestSh
        For Each sh In ActiveWorkbook.Worksheets
            If sh.Name <> DestSh.Name Then
                'Znajduje ostatni wiersz z danymi w arkuszach zródlowych
                LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
                'uzupelnia kolumne które maja byc skopiowane
                Set CopyRng = sh.Range("A2:D" & LastRow)
                'Sprawdza czy jest wystarczajaca ilosc wierszy w DestSh do skopiowania danych
                With DestSh
                    'Find next blank row at bottom of sheet
                    DZNextRow = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
                    If DZNextRow + LastRow > .Rows.Count Then
                        MsgBox "There are not enough Rows in the Destsh"
                        GoTo ExitTheSub
                    End If
                End With
                'kopiuje wartosci/formaty komórek
                CopyRng.Copy
                With DestSh.Cells(DZNextRow, 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            Application.ScreenUpdating = False
            ActiveSheet.Columns.AutoFit
        End If
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

nothing changed with my workbook still runtime 91

 

[JLGWhiz]

I need to understand where you are with the code. Are you getting error 91 on the code snippet in your post #23 while running the code in your post #20? I want to be sure we are looking at the same code and analyzing the same segment of code, so indicate the specific line that is highlighted when you click the debug button.

 

[Peter_SSs]

I'm really green with VB, but isn't this code line refering to source sheets?

Yes it is. It sets the variable LastRow equal to the row number of the last row where data is found.
If you have a worksheet, whose name is not "Dane Zbiorcze", that has no data on it then no value can be assigned to variable LastRow, hence the code would error and give the message "Object variable or With block variable not set" that you reported.

If you are still getting "Object variable or With block variable not set", I suggest that you add this line. It will report each sheet name as it is about to be processed so you can see which one is causing the problem, if I am on the right track,
BTW, do you have any hidden sheets?

If sh.Name <> DestSh.Name Then
    MsgBox sh.Name & " will now be processed"
    'Znajduje ostatni wiersz z danymi w arkuszach zródlowych
    LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row

When I debug this code line by line, error shows when i get to this part:

I'm not quite sure what you mean by that. When an error occurs, you generally have the option to click a button called 'Debug'. When you do that, you are not taken to a 'part' of the code, you are taken to a specific line that is highlighted yellow.


BTW, you do not have a line of code in post #20 that says this

When I debug this code line by line, error shows when i get to this part:

[COLOR="#FF0000"][B]ExitTheSub:    Application.Goto DestSh.Cells(1)[/B][/COLOR]
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[JLGWhiz]

@Peter, if you are going to stay with this, I am going to drop off. Too many cooks spoil the broth, etc. Regards, JLG

 

[PWSY86]

Thank you very much guys!!! Finally it works... The problem was caused by hidden worksheet with commadn button in it.
I'll buy you a beer if you ever have opportunity to visit Poland.
thisthread can be closed.


final code:

Sub DataCopyFromMultiShToDestSh()    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LastRow As Long
    Dim CopyRng As Range
    Dim DZNextRow As Long
    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"
    'Add headers in first row of selected range
    With DestSh
        .Cells(1, 1).Value = "Name"
        .Cells(1, 2).Value = "Name1"
        .Cells(1, 3).Value = "Name2"
        .Cells(1, 4).Value = "Name3"
    End With
        ' freeze first row as a header
        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With
        If Not ActiveSheet.AutoFilterMode Then
            ActiveSheet.Range("A1").AutoFilter
        End If
        'loop through all worksheets and copy the data to the DestSh
        For Each sh In ActiveWorkbook.Worksheets
            If sh.Name <> DestSh.Name Then
                'Find the last row with data on the DestSh
                LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
                'Fill in the column(s) that you want to copy
                Set CopyRng = sh.Range("A2:D" & LastRow)
                'Test if there enough rows in the DestSh to copy all the data
                With DestSh
                    'Find next blank row at bottom of sheet
                    DZNextRow = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
                    If DZNextRow + LastRow > .Rows.Count Then
                        MsgBox "There are not enough Rows in the Destsh"
                        GoTo ExitTheSub
                    End If
                End With
                'Copies values/formats and Column width
                CopyRng.Copy
                With DestSh.Cells(DZNextRow, 1)
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            Application.ScreenUpdating = False
            ActiveSheet.Columns.AutoFit
        End If
    Next
ExitTheSub:     Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Best regards,
Przemek

 

[JLGWhiz]

Thank you very much guys!!! Finally it works... The problem was caused by hidden worksheet with commadn button in it.
I'll buy you a beer if you ever have opportunity to visit Poland.
thisthread can be closed.


Przemek

Thanks for the feedback,
Regards, JLG