Need macro to copy multiple sheets in multiple files to one file one sheet

[Best3435]

have this code:

Sub MergeSheets()
Dim SrcBook As Workbook
Dim TrgtBook As Workbook
Dim fso As Object
Dim f As Object
Dim ff As Object
Dim i As Long
Dim SrcLCell
Dim TrgtLCell

Application.ScreenUpdating = False '<--- Stops Screenflicker
Application.DisplayAlerts = False '<--- Stops annoying Excel pop-up questions

Set TrgtBook = ThisWorkbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.Getfolder("C:\Documents and Settings\bestjon1\Desktop\Combine Sheets")
Set ff = CreateObject("Scripting.FileSystemObject")

For Each ff In f.Files
If ff.Name Like "*.xls" Then '<----- checks if it is an excel file, amend if necessary with 2007 extensions (Or ff.name like "*.xlsm" Or ...)
Workbooks.Open Filename:=f & "\" & ff.Name
Set SrcBook = ActiveWorkbook
For i = 1 To SrcBook.Sheets.Count
SrcBook.Sheets(i).UsedRange
TrgtBook.ActiveSheet.UsedRange

SrcLCell = SrcBook.Sheets(i).Cells(SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Row, SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Column).Address

If TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row > 1 Then
TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1, 1).Address
Else
TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row, 1).Address
End If

SrcBook.Sheets(i).Range("A1:" & SrcLCell).Copy
TrgtBook.Sheets(1).Range(TrgtLCell).PasteSpecial xlPasteValues '<--- pastes only the values, all formulas, formating etc is lost, remove / amend as necessary
Application.CutCopyMode = False

Next i

SrcBook.Saved = True
Workbooks(ff.Name).Close
End If
Next ff

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub



Need small change: What's the best way to make this work for select sheets in each file that I am using to combine? right now it works for all sheets in each file and I only want specific ones. Thanks,

 

[Gary McMaster]

The best way may depend on how many different sheet names there are. If there are just a few maybe Select Case will suffice:

Hope it helps.

Gary

For i = 1 To SrcBook.Sheets.Count

Select Case SrcBook.Sheets(i).Name

    Case "Sheet1", "Sheet6", "Sheet8" 'Process these sheet names skip others
        SrcBook.Sheets(i).UsedRange
        TrgtBook.ActiveSheet.UsedRange
        
        SrcLCell = SrcBook.Sheets(i).Cells(SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Row, SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Column).Address
        
        If TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row > 1 Then
        TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1, 1).Address
        Else
        TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row, 1).Address
        End If
        
        SrcBook.Sheets(i).Range("A1:" & SrcLCell).Copy
        TrgtBook.Sheets(1).Range(TrgtLCell).PasteSpecial xlPasteValues '<--- pastes only the values, all formulas, formating etc is lost, remove / amend as necessary
        Application.CutCopyMode = False
    
    Case Else
        'Do nothing or ...
        'Or put code here to process most and list sheets to skip above
End Select

Next i

End Sub

 

[Best3435]

Appreciate the reply, been trying to get back into this and knowledge is limited I guess. The code you gave me works, but nothing gets copied to the final spreadsheet.

 

[Gary McMaster]

You need to add the lines I included (highlighted in red) to your original code sample. My snip isn't meant to do anything other than show where the lines fit into the bigger picture.

If your code ran as originally posted it should run with these changes. Of course you will have to change the sheet names to match those in your workbook.

Gary

For i = 1 To SrcBook.Sheets.Count

[COLOR=Red]Select Case SrcBook.Sheets(i).Name[/COLOR]

    [COLOR=Red]Case "Sheet1", "Sheet6", "Sheet8" 'Process these sheet names skip others[/COLOR]
        SrcBook.Sheets(i).UsedRange
        TrgtBook.ActiveSheet.UsedRange
        
        SrcLCell = SrcBook.Sheets(i).Cells(SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Row, SrcBook.Sheets(i).Cells.SpecialCells(xlLastCell).Column).Address
        
        If TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row > 1 Then
        TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row + 1, 1).Address
        Else
        TrgtLCell = TrgtBook.ActiveSheet.Cells(TrgtBook.ActiveSheet.Cells.SpecialCells(xlLastCell).Row, 1).Address
        End If
        
        SrcBook.Sheets(i).Range("A1:" & SrcLCell).Copy
        TrgtBook.Sheets(1).Range(TrgtLCell).PasteSpecial xlPasteValues '<--- pastes only the values, all formulas, formating etc is lost, remove / amend as necessary
        Application.CutCopyMode = False
    
    [COLOR=Red]Case Else
        'Do nothing or ...
        'Or put code here to process most and list sheets to skip above
End Select[/COLOR]

Next i

End Sub

 

[Best3435]

I did that but nothing happens in the file. the code doesn't throw an error either.