Merge spreadsheets from 2 files into new workbook

[hellobaby]

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!

[MrBlackd]

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


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.

[MrBlackd]

'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??