Hello, Sorry about the length of this post, but I really need your help. So please bear with me.
I would like to merge a multitude of workbooks 5 - 15 (depending on the source) to populate to the main workbook. Keep in mind though, that each workbook will have similar data, but there maybe some worksheets that have data and some that don't. There are 14 worksheets in the workbook. So, what I need to do is create a macro that will
* Merge the workbooks without opening them
* When merging to the worksheets it will populate to the
worksheet in the Main workbookand will automatically go to the
next row
I recently found a macro on that will do this on the boards but, the infomation populates to a new worksheet. So for example, if I had a worksheet called Footwear in the Main Workbook it would create a Footwear 1, Footwear 2, Footwear 3, etc.
If anyone has any ideas please let me know. I am attaching the macro for your review. It is kind of lengthy so you may want to copy it or print it out.
Thank you for your help!!
Macro:
Option Explicit
Sub CopyWorksheets2()
Dim filenames As Variant
Dim strActiveBook As String
Dim strSourceDataFile As String
Dim wSht As Worksheet, wSht2 As Worksheet
Dim allwShts As Sheets, allwShts2 As Sheets
Dim Sheetname As String, response As String
Dim counter As Integer, intResponse As Integer
Application.DisplayAlerts = False
intResponse = MsgBox("This macro will copy all worksheets from selected files to the current workbook. Continue?", vbOKCancel, "Copy Worksheets to Current File")
If intResponse = vbOK Then
strActiveBook = ActiveWorkbook.Name
' Create array of filenames; the True is for multi-select
filenames = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , , , True)
On Error GoTo 1000
If filenames = False Then Exit Sub
1000
On Error GoTo 0
counter = 1
' ubound determines how many items in the array
On Error GoTo quit
response = MsgBox("Retain Original Worksheet Names? (If No, then each copied worksheet will be given the name of the Excel file from which it came.", vbYesNo, "Copy Worksheets")
Application.ScreenUpdating = False
If response = vbNo Then
While counter <= UBound(filenames)
'Opens the selected files
Workbooks.Open filenames(counter)
strSourceDataFile = ActiveWorkbook.Name
If strSourceDataFile <> strActiveBook Then
Set allwShts = Worksheets
For Each wSht In allwShts
Workbooks(strSourceDataFile).Activate
If wSht.Visible = True Then
Sheets(wSht.Name).Select
Sheets(wSht.Name).Copy before:= _
Workbooks(strActiveBook).Sheets(1)
Sheetname = Left(strSourceDataFile, Len(strSourceDataFile) - 4)
Workbooks(strActiveBook).Activate
'Check to see if a Sheet already has the name
If SheetExists(Sheetname) = True Then
ActiveSheet.Name = Left(strSourceDataFile, Len(strSourceDataFile) - 4) & "(" & wSht.Index & ")"
Else
ActiveSheet.Name = Left(strSourceDataFile, Len(strSourceDataFile) - 4)
End If
End If
Next wSht
Workbooks(strSourceDataFile).Activate
ActiveWorkbook.Close
' displays file name in a message box
MsgBox strSourceDataFile & " Has Been Processed", vbOKOnly + vbInformation, "File Processed"
End If
'increment counter
counter = counter + 1
Wend
Else
While counter <= UBound(filenames)
'Opens the selected files
Workbooks.Open filenames(counter)
strSourceDataFile = ActiveWorkbook.Name
If strSourceDataFile <> strActiveBook Then
'Copy all worksheets except "Specifications"
Set allwShts = Worksheets
For Each wSht In allwShts
If wSht.Visible = True Then
Workbooks(strSourceDataFile).Activate
Sheets(wSht.Name).Select
Sheets(wSht.Name).Copy before:= _
Workbooks(strActiveBook).Sheets(1)
End If
Next wSht
Workbooks(strSourceDataFile).Activate
ActiveWorkbook.Close
' displays file name in a message box
MsgBox strSourceDataFile & " Has Been Processed", vbOKOnly + vbInformation, "File Processed"
End If
'increment counter
counter = counter + 1
Wend
End If
quit:
If Err <> 0 Then
MsgBox "An Error Occurred Trying to open the File. Please close any open Excel files and try again", vbOKOnly + vbExclamation, "File Open Error"
On Error GoTo 0
End If
End If
Set allwShts = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sname) As Boolean
' Returns TRUE if sheet exists in the active workbook
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
On Error GoTo 0
End Function
