Merge spreadsheets from 2 files into new workbook

Hi everyone,I am trying to merge 2 files (FileA and FileB) into a new file which will be automatically named based on the date. I would only need Sheet 2 of both files to be copied over and merged into the new file. The range to be copied is from Row 3 onwards to whichever point where the data ends. All the files can be found in a specific drive and the new file should be created there as well.

The 2 files that I want to merge are called FileA.xls and FileB.xls. I hope the macro is able to merge and create a new file named based on today date for eg. (031013.xls) in the same drive where the files are (C:\Desktop). I will only need to merge "Sheet2" from row 3 onwards of FileA and FileB.

Can anyone help?Thanks in advance!

You can do the following...

1) open the files that you need merged

2) Create a module and name it ConsolidateWB (or whatever you like) and paste in there

Code:

---

Option Explicit

Sub Consolidate()

Dim ws As Worksheet
Dim Wb As Workbook, NewBook As Workbook
Dim scount As Integer
Dim NewWS As Worksheet
Dim wsSheet As Worksheet
Dim i As Integer
Dim NextName As String
Dim sl As Integer
Dim newfilepath As String
    newfilepath = ""
Dim first_only As Boolean
    first_only = False
Dim lReply As Long
   
' make StatusBar visible
Application.DisplayStatusBar = True
'First Message
Application.statusbar = String(5, ChrW(46)) & " Starting"
Application.Wait Now + TimeValue("00:00:02")

'are we doing the first sheet only?
lReply = MsgBox("To merge  All Sheets select 'Yes'" & " " & " To merge First Sheet Only select 'No'", vbYesNoCancel, "Choose sheets to merge")
If lReply = vbCancel Then Exit Sub
   
    If lReply = vbNo Then first_only = True

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
   
'Second Message
Application.statusbar = String(10, ChrW(46)) & " Working"
Application.Wait Now + TimeValue("00:00:02")

'Create new workbook for merged sheets


newfilepath = Environ("USERPROFILE") & "\Desktop\Merged"  'excel will auto append the appropriate extension (xlsx)
Set NewBook = Workbooks.Add
NewBook.SaveAs FileName:=newfilepath

i = 1

'Loop through each open workbook
For Each Wb In Workbooks
 
    If Wb.Name <> ThisWorkbook.Name And Wb.Name <> NewBook.Name And Left(Wb.Name, 8) <> "PERSONAL" Then
   
    Dim x As String
   
    'Get name of this workbook
    x = JustText(Left(Wb.Name, Len(Wb.Name) - 4))
       
        'count sheets in this workbook
        If first_only Then
            scount = 1
        Else
            scount = Wb.Sheets.Count
        End If
       
        'Loop through each sheet in Workbook
        For Each ws In Wb.Worksheets
       
            'do some naming conventions
            Dim xy As String
            Dim y As String
           
            y = JustText(ws.Name) 'strip out all characters from name
           
            If scount > 1 Then
           
              xy = x + y
             
            Else
             
              xy = x
             
            End If
           
            'check the length of the new name and shorten if needed
            sl = Len(xy)
           
            If sl > 30 Then
           
                xy = Right(x, sl - (sl - 30))
           
            End If
           
            'copy worksheet to new workbook
            ws.Copy After:=NewBook.Worksheets(NewBook.Worksheets.Count)
           
            'rename worksheet
            NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy
            If scount = 1 Then Exit For 'break out of loop if we are only doing one sheet
       
        Next

    End If

Next

'Third Message
Application.statusbar = String(15, ChrW(46)) & " Finalizing"
Application.Wait Now + TimeValue("00:00:02")

'remove all original worksheets
NewBook.Worksheets("Sheet1").Delete
NewBook.Worksheets("Sheet2").Delete
NewBook.Worksheets("Sheet3").Delete


ErrorExit: 'Cleanup
    Application.DisplayAlerts = True    'turn system alerts back on
    Application.EnableEvents = True    'turn other macros back on
    Application.ScreenUpdating = True  'refreshes the screen

'Last Message
Application.statusbar = String(15, ChrW(46)) & " Done!"
Application.Wait Now + TimeValue("00:00:02")
'-- Replace this line with your own code to do something

'Relinquish the StatusBar
Application.statusbar = False

ActiveWorkbook.Save
End Sub

Private Function JustText(text_to_clean As String, Optional upper As Boolean = False)
    'removes all characters except for letters and numbers
    'where
    'text_to_clean is the text to clean
    'upper boolean will return UPPER case if true; false if omitted
 
    'declare and initialize user variables
     
    Dim method As Integer
        'choices:
        '1=remove everything except what is in the leave_these variable
        '2=leave everything except what is specifically removed from the "leave" section
        method = 1
 
    Dim leave_these As String  'only used if method=1
        leave_these = "A-Za-z0-9" 'if you want to allow a space "A-Za-z0-9 "

    'declare and initialize system variables
    Dim temp As String
        temp = text_to_clean
     
    'method
    Select Case method
        Case 1  'remove everything except what is in the leave_these variable
            Dim x As String, y As String, z As String, i As Long
            x = temp
                For i = 1 To Len(x)
                    y = Mid(x, i, 1)
                    If y Like "[" & leave_these & "]" Then z = z & y
                Next i
            temp = z
     
        Case 2  'leave everything except characters below
            'feel free to comment out the lines for items you do not wish to remove, or add new lines as desired
            temp = Replace(temp, ",", "")  'remove commas
            temp = Replace(temp, " ", "")  'remove spaces
            temp = Replace(temp, "-", "")  'remove dashes
            temp = Replace(temp, ":", "")  'remove colon
            temp = Replace(temp, ";", "")  'remove semi-colon
         
    End Select

 
    If upper Then JustText = UCase(temp) Else JustText = temp
 
End Function

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0

End Function

---

3) Run Macro "Consolidate"

Doing the above will merge all the currently open workbooks into a new file that will be placed in Desktop with the name Merged.xlsx
You will also be prompted to reply if you want to merge the 1st sheet only or all.


I have found this on the web, I take no credit for compiling any of this.
Sadly I do not have the reference to the original code source.

The only changes that I have done to the code structure are immaterial and restricted to:

• adding a message about the progress in the statusbar but slows the code a bit so you can remove it if you want
• originally the file was created on Desktop was xls and changed it to xlsx
• and finally I changed the way Desktop folder is located (that under Win7 is username related) so that it could work for multiple users

I hope that this will help you.

You can afterwards delete any of the sheets you don't want to keep.

Mr.B.

Code:

---

'rename worksheet
NewBook.Worksheets(NewBook.Worksheets.Count).Name = xy

---

My proposed solution that I had found online and shared gets stuck in the row posted.

Any ideas why????



Anybody??