Creating multiple workbooks based on naming scheme

[ksbcis]

Hi VBAX!

I have a question regarding creating new workbooks from multiple workbooks with a specific naming scheme. For example, using the information below, there are 9 different reports for each property. "2HERALD" and "3COLUMBUS" is the property. If you notice, however, there are 9 different versions of this report (LEDIT-1, BOOK-1, CFP-1, etc....). What I would like to do is create new workbooks based on the different versions of the for each property. For example, any property that has LEDIT-1 in the naming scheme, I would like to create a new workbook titled "LEDIT-1" and within this new workbook, each property will have its own spreadsheet with the "LEDIT-1" in the naming scheme. In this case, the new workbook, "LEDIT-1", will have "2HERALD-ROLL-LEDIT-1.xls" as the first spreadsheet and "3COLUMBUS-ROLL-LEDIT-1.xls" as the second spreadsheet, etc....if there were more properties with "LEDIT-1" in the name, it would be added to this new workbook as well as another spreadsheet.

These are all workbooks with only one spreahseet within them.

2HERALD-ROLL-LEDIT-1.xls
2HERALD-ROLL-BOOK-1.xls
2HERALD-ROLL-CFP-1.xls
2HERALD-ROLL-CFP-2.xls
2HERALD-ROLL-CFP-3.xls
2HERALD-ROLL-LASS-1.xls
2HERALD-ROLL-OCC-1.xls
2HERALD-ROLL-RENTROLL-1.xls
2HERALD-ROLL-TASS-1.xls

3COLUMBUS-ROLL-LEDIT-1.xls
3COLUMBUS-ROLL-BOOK-1.xls
3COLUMBUS-ROLL-CFP-1.xls
3COLUMBUS-ROLL-CFP-2.xls
3COLUMBUS-ROLL-CFP-3.xls
3COLUMBUS-ROLL-LASS-1.xls
3COLUMBUS-ROLL-OCC-1.xls
3COLUMBUS-ROLL-RENTROLL-1.xls
3COLUMBUS-ROLL-TASS-1.xls

My good buddy Mark, aka GTO, was able to help me with the code for creating a similar report that allows you to create workbooks based on the property name. So taking the sample data above and using "2HERALD" I was able to create a new workbook titled "2HERALD" and have the 9 different versions for "2HERALD" (3COLUMBUS-ROLL-LEDIT-1.xls, 3COLUMBUS-ROLL-BOOK-1.xls, 3COLUMBUS-ROLL-CFP-1.xls, etc...) dumped into this new workbook, titled "2HERALD". I would like to do the same thing, except, now I would like to have the versions of the reports as workbooks. So again using "2HERALD-ROLL-LEDIT-1.xls" as an example, I would like to create a new workbook where it is titled "LEDIT-1" and any property with the "LEDIT-1" in it's name will be in this new workbook titled "LEDIT-1". In this case, the spreadsheets in this new workbook will be ("2HERALD-ROLL-LEDIT-1.xls" and "3COLUMBUS-ROLL-LEDIT-1.xls").

The code that was provided by GTO simply needs to be modified to accomplish this task. Anyone knows how to modify this? I would greatly appreciate your help!

[vba]Option Explicit

Sub MergeDataByWBGroup()
Dim FSO As Object ' FileSystemObject
Dim fsoFol As Object ' Folder
Dim fsoFil As Object ' File
Dim DIC As Object ' Dictionary
Dim WB As Workbook
Dim WBNew As Workbook
Dim wks As Worksheet

Dim Keys() As Variant
Dim Path As String
Dim PathNew As String
Dim i As Long

Path = ThisWorkbook.Path & "\"

'// Set references to new Dictionary and FileSystemObject Objects, as well as to the//
'// folder ThisWorkbook resides in. //
Set DIC = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fsoFol = FSO.GetFolder(ThisWorkbook.Path & "\")

For Each fsoFil In fsoFol.Files
'// For ea file in the folder, test to see it meets our criterias of: filename //
'// ends in .xls, .xlsm, .xlsx,..., AND there's a hyphen in the filename, AND //
'// its not ThisWorkbook. //
If Mid(fsoFil.Name, InStrRev(fsoFil.Name, ".") + 1) Like "xls*" _
And InStr(1, fsoFil.Name, "-") > 0 _
And Not fsoFil.Name = ThisWorkbook.Name Then
'// IF we passed those tests, assign what's left of the first hyphen //
'// (trimmed) to a unique key. When we run into other filenames similar, //
'// .Item just gets overwritten, so no need to check .Exists. //
DIC.Item(Trim(Left(fsoFil.Name, InStr(1, fsoFil.Name, "-") - 1))) = Empty
End If
Next

'// Then assign our unique keys to an array. //
Keys = DIC.Keys

'// Optional, I create a folder to hold the new wb's in. //
If Not FSO.FolderExists(Path & "Temp") Then
FSO.CreateFolder Path & "Temp"
End If
PathNew = Path & "Temp\"

'// For ea element in our array... //
For i = LBound(Keys) To UBound(Keys)
'// ...create a new wb to plunk the sheets in. //
Set WBNew = Workbooks.Add(xlWBATWorksheet)
'// Then loop thru the files in the folder to see... //
For Each fsoFil In fsoFol.Files
'// ...if the file matches what we're looking for to group by. //
If fsoFil.Name Like Keys(i) & "*" Then
'// If TRUE, set a reference to the file while opening it,... //
Set WB = Workbooks.Open(fsoFil.Path, False)
'// ...copy the one sheet to the end of our created wb,... //
WB.Worksheets(1).Copy After:=WBNew.Worksheets(WBNew.Worksheets.Count)

'// ...rename the copied worksheet and then,... //
WBNew.Worksheets(WBNew.Worksheets.Count).Name = _
Left(Left(fsoFil.Name, InStrRev(fsoFil.Name, ".") - 1), 31)

'(NOTE: I figure the above is where trouble may arise. If there are)
'( many files and some have longer names, we may have to handle)
'( the possibility of the first 31 chars being the same. )

'// ...close the found wb w/o saving any changes. //
WB.Close False
End If
Next

'// Back to our outer loop, we have now added a sheet for ea file that matched //
'// and we can delete the one blank sheet that the created wb started with. //
Application.DisplayAlerts = False
WBNew.Worksheets(1).Delete
Application.DisplayAlerts = True

'// SaveAs and close the created wb. //
WBNew.SaveAs PathNew & Keys(i) & ".xls"
WBNew.Close False
Next
End Sub[/vba]



Thanks,

ksbcis