PDA

View Full Version : Solved: Merge Workbooks



tkaplan
12-01-2005, 07:55 AM
I have a folder with about 300 workbooks in them, each workbook having one sheet.

The format of the name of each of the workbooks it <<text>>XXXX.xls with the XXXX being four numbers.

I want to open up each of these files, take the one sheet and copy it to one workbook, with the tab name being XXXX.

I wrote the following macro:


Sub CopySheets()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

With ActiveWorkbook
MyPath = .Path & "\wkbks"
End With

ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
Else
MsgBox Len(FNames) & " files found"
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = Left(Right(mybook.Name, 8), 4)
' ActiveSheet.Name = Left(ActiveSheet.Name, Len(ActiveSheet.Name) - 4)
On Error GoTo 0
mybook.Close False
FNames = Dir()
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub



This macro works when I test it out on 25 books.
the line "MsgBox Len(FNames) & " files found"" only recognizes up to 25 books.

How can I do this without the 25 book limit??

geekgirlau
12-01-2005, 07:44 PM
I would have thought that Len(FNames) is only the number of characters in the name, not the number of files found.

johnske
12-02-2005, 02:46 AM
Each of the numbers in the names are unique? Put each workbook in the same folder (by themselves), run the code and wait (tested with 50 workbooks)...Option Explicit

Sub AmalgamateAll()

Dim i As Long, ThisBook As Workbook, OtherBook As Workbook

Set ThisBook = ActiveWorkbook

Application.ScreenUpdating = False
With Application.FileSearch
.LookIn = ActiveWorkbook.Path
.FileName = "*.xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
On Error Resume Next
If .FoundFiles(i) = ThisWorkbook.FullName Then
Sheets(1).Name = Right(Left(ThisWorkbook.Name, _
Len(ThisWorkbook.Name) - 4), 4)
[A1].Select
Else
Application.Workbooks.Open(.FoundFiles(i)).Activate
Set OtherBook = ActiveWorkbook
With OtherBook
Sheets(1).Activate
Cells.Copy
With ThisBook
.Activate
Worksheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = Right(Left(OtherBook.Name, _
Len(OtherBook.Name) - 4), 4)
.Paste
[A1].Select
End With
Application.CutCopyMode = False
End With
.Activate
End With
With OtherBook
.Close False
End With
End If
Next i
End If
End With
Set ThisBook = Nothing
Set OtherBook = Nothing
Sheet1.Activate
Application.ScreenUpdating = True
End Sub

tkaplan
12-02-2005, 08:47 AM
ok, i ran my code again and it worked. I think geekgirl is correct. it is only counting the chars in the file name.

thank you john for the more elegant code. i am going to use that as a little guide for me:)

parttime_guy
01-15-2006, 09:26 PM
Hi Guz

I have tried this code (it works) for 1 sheet only - But assuming you have 5 sheets (different names) in the 1st workbook and 7 sheets (different names) in the 2nd workbook, but how do I copy all sheets in the said workbooks with their respective sheet name into the final workbook, is there a line which needs to be included, another thing if any of the workbooks have blank sheets does it skip those - plz help

Thx-n-BR