Looping through specific sheets in an excel work book and copying data in different work sheet

[naitrar]

Hi all,
I'm trying to copy information from several specific sheets in a workbook, without copying information from irrelevant sheets, to a single sheet called Merge. The name of the sheets where i want to copy the information from is: Summary, Summary(1)... Summary(n+1).
In addition, i want the copied information to be pasted after the last row with information and without deleting the header line.


The code i'm using is a mix and match from various answers in different Excel-VBA forums so it's not elegant and probably has lots of errors caused by my limited understanding of VBA and coding as a whole.


This is the code i currently have:


Sub Copy_1()
Dim SourceRange As Range, DestRange As Range
Dim DestSheet As Worksheet, Lr As Long

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

'Deleting the information from sheet ñéëåí
Sheets("Merge").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

'loop through all worksheets and copy the data to the DestSh
For Each sh In ThisWorkbook.Worksheets


'Loop through all worksheets except the Merge worksheet and the
'Information worksheet, you can add more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSheet.Name, "Merge"), 0)) Then
'fill in the Source Sheet and range
'Set SourceRange = Sheets("Summary").Range("A2:L100")
Set SourceRange = sh.Range("A2:N100")
SourceRange.Copy

'Fill in the destination sheet and call the LastRow
'function to find the last row
Set DestSheet = Sheets("øéëåæ")
Lr = LastRow(DestSheet)


'With the information from the LastRow function we can
'create a destination cell and copy/paste the source range
Set DestRange = DestSheet.Range("A" & Lr + 1)
'Set DestRange = DestSheet.Range("A" & Last + 1)
'End If

'SourceRange.Copy DestRange
SourceRange.Copy
With DestSheet.Cells(2, Last + 1)
.PasteSpecial 8 ' Column width
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Next


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With


End Sub


I would greatly appreciate your help as i've already spent hours going through various answers on similar issues in different forums and trying to solve this on my own.


Thanks a lot!

 

[Leanna]

Try this

Sub Copy_1()
Dim SourceRange As Range, DestRange As Range
Dim DestSheet As Worksheet, Lr As Long
shNames = Split("Summary~Summary(1)~Summary(2)", "~")
Set DestSheet = Sheets("Merge")


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


'Deleting the information from sheet ñéëåí
Sheets("Merge").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents


'loop through worksheets in shNames and copy the data to the DestSh
For Each shName In shNames
    Set sh = Sheets(shName)
    ''Loop through all worksheets except the Merge worksheet and the
    ''Information worksheet, you can add more sheets to the array if you want.
    'If IsError(Application.Match(sh.Name, _
    'Array(DestSheet.Name, "Merge"), 0)) Then
    ''fill in the Source Sheet and range
    ''Set SourceRange = Sheets("Summary").Range("A2:L100")
    Set SourceRange = sh.Range("A2:N100")
    
    'Last row is determined due to last filled cell in B column
    Lr = DestSheet.Cells(Rows.Count, "B").End(xlUp).Row
        
    'With the information from the LastRow function we can
    'create a destination cell and copy/paste the source range
    Set DestRange = DestSheet.Range("A" & Lr + 1)
    'Set DestRange = DestSheet.Range("A" & Last + 1)
    'End If
    
    'SourceRange.Copy DestRange
    SourceRange.Copy
    With DestSheet.Cells(Lr + 1, 1)
    .PasteSpecial 8 ' Column width
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    End With
Next




With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With




End Sub

 

[dmt32]

Hi welcome to the board,
Not tested but see if this update to your code goes in direction you are looking for:

Sub Copy_1()
 
    Dim SourceRange As Range, DestRange As Range
 
    Dim DestSheet As Worksheet, sh As Worksheet
 
    On Error GoTo myerror
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
 
    'Merge Worksheet
    Set DestSheet = Sheets("Merge")
 
    'Deleting the information from Merge sheet
    DestSheet.UsedRange.Offset(1, 0).ClearContents
 
    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ThisWorkbook.Worksheets
 
        Select Case sh.Name
            'exclude Merge and Information worksheets
        Case "Merge", "Information"
 
            'do nothing
 
        Case Else
 
            'get Source Sheet data range
            Set SourceRange = sh.Range("A2:N" & sh.Cells(sh.Rows.Count, "A").End(xlUp).Row)
            'get the destination sheet LastRow + 1
            Set DestRange = DestSheet.Range("A" & DestSheet.Cells(DestSheet.Rows.Count, "A").End(xlUp).Row + 1)
 
            'Copy Source Sheet
            SourceRange.Copy
 
            With DestRange
                .PasteSpecial 8    ' Column width
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With
        End Select
 
        Set SourceRange = Nothing
        Set DestRange = Nothing
    Next
 
myerror:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Amend code to to meet your specific project need as required.

Hope Helpful

Dave

 

[naitrar]

Hi Dave,
Thank you so much!
The code worked perfectly!

Nir

 

[naitrar]

Hi Leanna,
Thanks a lot for taking the time to help me!

Nir

 

[naitrar]

///