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]

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

@Peter
You answered you own question here, Peter. That is why the xlFormulas is used. And If the OP has formulas below the visible data and does not want to copy them, then your suggestion is the proper one. But, the original code was copying entire columns, so I assumed the OP wanted 'everything' in the target columns.

Good catch on the End With. I re-did that in a hurry and did not test it.

Regards, JLG

 

[Peter_SSs]

But, the original code was copying entire columns, so I assumed the OP wanted 'everything' in the target columns.

Fair enough.
We'll wait & see but I guess it is quite likely an irrelevant issue anyway.

 

[PWSY86]

Thanks guys, finally it works for me, but still need your help...

i want to copy first row from Sheet1 as a Header in Target sheet,
and when there's no data in column A (but I have data in other columns) nothing is coppied

 

[PWSY86]

Solved problem with headers. Only problem left is with no copy when first column cell is empty.

 

[Peter_SSs]

There has been a few changes and/or suggested changes. Perhaps you should post the code you are currently using so we know for sure what we are dealing with.

 

[PWSY86]

Sorry for that, code looks like that now:

Sub KopiaDanychDoNowegoArkusza()Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LastRow As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Usuwa 'Dane Zbiorcze' jeśli 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 nagłówki w pierwszym rzędzie
    With DestSh
        .Cells(1, 1).Value = "Nazwa Kina"
        .Cells(1, 2).Value = "Sieć"
        .Cells(1, 3).Value = "Miasto"
        .Cells(1, 4).Value = "Województwo"
    ' zamraża pierwszy rząd
    With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With
         
    If Not ActiveSheet.AutoFilterMode Then


    ActiveSheet.Range("A1").AutoFilter
  End If


    'zapętla przez wybrane skoroszyty i kopiuje dane do DestSh
    For Each sh In ActiveWorkbook.Sheets(Array("Helios", "Multikino+SS", "Cinema City", "Cinema 3D"))
            'Znajduje ostatni wiersz z danymi w arkuszach źródłowych
            LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            'uzupełnia kolumne które mają być skopiowane
            Set CopyRng = sh.Range("A2:D" & LastRow)
            'Sprawdza czy jest wystarczająca ilość wierszy w DestSh do skopiowania danych
            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
            'kopiuje wartości/formaty komórek
            CopyRng.Copy
            With DestSh.Cells(Rows.Count, 1).End(xlUp)(2)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
                Application.ScreenUpdating = False
                ActiveSheet.Columns.AutoFit
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    End With
End Sub

sorry for comments in Polish in Code

 

[Peter_SSs]

sorry for comments in Polish in Code

No problem.

The issue is not that nothing is copied if column A is blank but that successive data gets copied over the top.

Declare one more variable at the top

Dim DZNextRow as Long

and make these changes in the code where shown

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

 

[PWSY86]

Superb

last thing, is it good thinking, if I would like to loop all active worksheets for specified data.
Change this lines

For Each sh In ActiveWorkbook.Sheets(Array("Helios", "Multikino+SS", "Cinema City", "Cinema 3D"))

to this

[COLOR=blue][FONT=Consolas]For[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] [/FONT][/COLOR][COLOR=blue][FONT=Consolas]Each[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] sh [/FONT][/COLOR][COLOR=blue][FONT=Consolas]In[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] ActiveWorkbook.Worksheets
[/FONT][/COLOR][COLOR=#000000][FONT=Consolas]        [/FONT][/COLOR][COLOR=blue][FONT=Consolas]If[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] sh.Name <> DestSh.Name [/FONT][/COLOR][COLOR=blue][FONT=Consolas]Then[/FONT][/COLOR]

When I do that I get run time error Object variable or With blockvariable not set

 

[Peter_SSs]

Superb

last thing, is it good thinking, if I would like to loop all active worksheets for specified data.
Change this lines

For Each sh In ActiveWorkbook.Sheets(Array("Helios", "Multikino+SS", "Cinema City", "Cinema 3D"))

to this

[COLOR=blue][FONT=Consolas][COLOR="#FF0000"]For[/COLOR][/FONT][/COLOR][COLOR=#000000][FONT=Consolas] [/FONT][/COLOR][COLOR=blue][FONT=Consolas][COLOR="#FF0000"]Each[/COLOR][/FONT][/COLOR][COLOR=#000000][FONT=Consolas] sh [/FONT][/COLOR][COLOR=blue][FONT=Consolas]In[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] ActiveWorkbook.Worksheets
[/FONT][/COLOR][COLOR=#000000][FONT=Consolas]        [/FONT][/COLOR][COLOR=blue][FONT=Consolas]If[/FONT][/COLOR][COLOR=#000000][FONT=Consolas] sh.Name <> DestSh.Name [/FONT][/COLOR][COLOR=blue][FONT=Consolas]Then[/FONT][/COLOR]

When I do that I get run time error Object variable or With blockvariable not set

Yes, that would be the way to go, but two things:

1. For Each not ForEach

2. You've added a new 'If' statement so you need the corresponding 'End If' and that would go just above the 'Next' which is just above 'ExitTheSub:'

 

[PWSY86]

change made:

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' jeśli 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 nagłówki w pierwszym rzędzie
    With DestSh
        .Cells(1, 1).Value = "Nazwa Kina"
        .Cells(1, 2).Value = "Sieć"
        .Cells(1, 3).Value = "Miasto"
        .Cells(1, 4).Value = "Województwo"
    ' zamraża pierwszy rząd
    With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With
         
    If Not ActiveSheet.AutoFilterMode Then


    ActiveSheet.Range("A1").AutoFilter
  End If


    'zapętla 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 źródłowych
            LastRow = sh.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).Row
            'uzupełnia kolumne które mają być skopiowane
            Set CopyRng = sh.Range("A2:D" & LastRow)
            'Sprawdza czy jest wystarczająca ilość 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 With
End Sub

stil getting this error