Solved: Combining workbooks into one workbook with a part of the a filename

[DAMAN]

Hi,

I have multiple excel books in the same folder. The filenames of each workbook have the same name ending and I would like to combine the workbooks with the same ending onto 1 workbook with the different worksheets.

For example

Workbook 1 file ame is John Sales - North.xls
Workbook 2 file name is Jack Sales – North.xls
Workbook 3 file name is Jill Sales – North.xls

I would like to combine the three workbooks into 1 workbook called North with three worksheets, is this possible to automate with some code

Thanks in advance.

[mbarron]

The following will ask you to choose a file from the directory.

It takes the last word in the file name from the last word in the file. In your example, the new file will be called North.xls
It then loops through the files in the directory and extracts the first sheet in the file and inserts it into the new file.
It renames the new sheet to the file name up to the dash in the file name. In your example you would have sheets called John Sales, Jack Sales, and Jill Sales
It then removes sheets that were not imported
Lastly it saves the file.
Sub groupBooks()

Application.ScreenUpdating = False
Dim wbkTo As Workbook 'current book
Dim wsTo As Worksheet 'dest sheet in current book
Dim wbFr As Workbook 'wb from directory
Dim wsFr As Worksheet
Dim strPath As String 'location directory of files
Dim strFile As String 'file name
Dim i As Long, j As Long, fCount As Integer, f As Integer
Dim strDirect As String
Dim wrkCur As Workbook
Dim strNewFile As String, strSheet As String
Dim wbNew As Workbook
Dim iShCount As Integer

iShCount = 1
'x-x-x-x gets the directory for import x-x-x-x

Set wrkCur = ActiveWorkbook
Application.Dialogs(xlDialogOpen).Show
If wrkCur.Name = ActiveWorkbook.Name Then
MsgBox "You canceled the operation", vbExclamation
Exit Sub
End If
strPath = ActiveWorkbook.Path & "\"
strNewFile = Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, " ") + 1, 99)
ActiveWorkbook.Close savechanges:=False
Workbooks.Add
Set wbNew = ActiveWorkbook
strFile = Dir(strPath & "*.xls")


Do While Not strFile = ""
'x-x-x-x-x-x Do stuff with the workbooks x-x-x-x-x-x-x-x
Set wbFr = Workbooks.Open(strPath & strFile)
Set wsFr = wbFr.Sheets(1)
strSheet = Left(wbFr.Name, InStr(wbFr.Name, "-") - 1)

wsFr.Copy Before:=wbNew.Sheets(iShCount)
iShCount = iShCount + 1
ActiveSheet.Name = strSheet

wbFr.Close savechanges:=False
strFile = Dir

Loop

Dim delSht As Worksheet
Application.DisplayAlerts = False
For Each delSht In wbNew.Sheets
If delSht.Index > iShCount - 1 Then
delSht.Delete
End If
Next
Application.DisplayAlerts = True
ActiveWorkbook.SaveAs Filename:=strNewFile
End Sub

[DAMAN]

Thanks mbarron, it worked in part however when I tested by creating three files in the same folder,

Jack Sales - North
John Sales - North
Jill Sales - South

When I ran the code it pulled all three files into 1 workbook called North, is there any possibilty that the the North File just containing Jack and John. I am a real newbie to vba, so any help would be greatly appreciated. Thank you.

PS the code you did the other day has saved me so much time at work.

[Aussiebear]

The code is designed to pull all files out of your folder. So if you had 50 fifty files there it'll deal with the lot. Simple solution.... only have the files in the folder you want the code to handle.

[DAMAN]

Thanks Aussie Bear, yes you are right I could manually move 4 files(as they have the same last name as in the example above) into a folder at a time and run the code and it would work perfectly, however there are 200 plus files in the one folder, so I am hoping to cut that manual step out

[Aussiebear]

Hi,

I would like to combine the three workbooks into 1 workbook called North with three worksheets, is this possible to automate with some code




When I ran the code it pulled all three files into 1 workbook called North, is there any possibilty that the the North File just containing Jack and John.

The correct information at the time of request would be very helpful.

What rules are to apply to decide what files get gathered into the composite file?

When does this event/s occur?

[GTO]

Greetings,

PResuming we can count on the hyphen, maybe:
Option Explicit

Enum eSheetOrFile
Namingfile = 1
NamingSheet = 2
End Enum

Sub CombineAreaFiles()
Dim _
FSO As Object, _
fsoFol As Object, _
fsoFil As Object, _
strFol As String, _
strFil As String, _
WB As Workbook, _
WBNew As Workbook, _
wks As Worksheet

'// Create a reference to the FileSystemObject //
Set FSO = CreateObject("Scripting.FileSystemObject")

'// I'm working in 2000, chose GetOpenFilename to get the fullname. //
strFil = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Pick a file in the folder...", _
MultiSelect:=False)

'// Rip the fullpath //
strFol = FSO.GetParentFolderName(strFil) & "\"

'// Bail here if something goofy (user didn't choose) //
If FSO.FolderExists(strFol) Then
Set fsoFol = FSO.GetFolder(strFol)
Else
MsgBox "No legit folder"
Exit Sub
End If

'// See function//
strFil = Area_Ret(strFil)

'// Ensure dest wb doesn't already exist //
If Not FSO.FileExists(ThisWorkbook.Path & "\" & strFil & ".xls") Then
Set WBNew = Workbooks.Add(xlWBATWorksheet)
WBNew.SaveAs Filename:=ThisWorkbook.Path & "\" & strFil & ".xls"
Else
MsgBox "Wokbook already exists...", vbOKOnly, vbNullString
Exit Sub
End If

'// For ea file in chosen folder... //
For Each fsoFil In fsoFol.Files

'// If file is wb AND filename has match (ie - North, South, whatever is //
'// hyphen) to strFil, then... //
If fsoFil.Type = "Microsoft Excel Worksheet" _
And Area_Ret(fsoFil.Name) = strFil Then

'// Set references to the opening wb and sheet1 thereof, //
Set WB = Workbooks.Open(Filename:=strFol & fsoFil.Name, _
ReadOnly:=True)
Set wks = WB.Worksheets(1)

'// Copy first sheet from source to after last sheet in dest (ThisWorkbook)//
'// close source, and re-set reference to copied sheet in dest. //
With WBNew
wks.Copy After:=.Worksheets(.Worksheets.Count)
WB.Close SaveChanges:=False
Set wks = .Worksheets(.Worksheets.Count)
End With

'// Using the filename of the source wb, if such a sheetname does not //
'// exist in dest, AND, name is legal (pobably overkill), then rename //
'// copied sheet. //
If Not ShExists(Left(fsoFil.Name, InStrRev(fsoFil.Name, ".") - 1)) _
And IsLegalName(Left(fsoFil.Name, InStrRev(fsoFil.Name, ".") - 1)) Then
wks.Name = Left(fsoFil.Name, Application.Min(InStrRev(fsoFil.Name, ".") - 1, 31))
End If
End If
Next

Application.DisplayAlerts = False
WBNew.Worksheets(1).Delete
WBNew.Close True
Application.DisplayAlerts = True


End Sub

Function ShExists(ShName As String, _
Optional WB As Workbook, _
Optional IgnoreCase As Boolean = False) As Boolean
Dim wks As Worksheet

If WB Is Nothing Then
Set WB = ThisWorkbook
End If

If IgnoreCase Then
On Error Resume Next
Set wks = Worksheets(ShName)
On Error GoTo 0

ShExists = CBool(Not wks Is Nothing)
Else
On Error Resume Next
ShExists = CBool(WB.Worksheets(ShName).Name = ShName)
On Error GoTo 0
End If
End Function

Function IsLegalName(StringInput As String, _
Optional NameType As eSheetOrFile = NamingSheet) As Boolean

If NameType = Namingfile Then
IsLegalName = CBool(Not StringInput Like "*[.""/\[:;=,]*" _
And Not StringInput Like "*]*")
Else
IsLegalName = CBool(Not StringInput Like "*[:\/?*[]*" _
And Not StringInput Like "*]*")
End If
End Function

Function Area_Ret(StringIn As String) As String 'REX As RegExp,
Static REX As RegExp

'// Use a Static variable, so we only have to create the object once (thanks to XLD)//
If REX Is Nothing Then
Set REX = CreateObject("VBScript.RegExp")
'// True so that we'll .Replace all occurrences in the string that match the //
'// Pattern. //
REX.Global = True
'// I am definitely baby-stepping RegExp's, but I think: //
'// Anything other than newline (zero to unlimited len), followed by one hyphen,//
'// followed by zero to unlimited spaces, followed by a word boundary. //
'// OR (alternation) //
'// One dot, followed by three to four letters (ie - the extension). //
'// to unlimited spaces, followed by
REX.Pattern = ".*-\ *\b|[.][a-z]{3,4}"
End If

'// Return the string with matches replaced by nullstring(s) //
Area_Ret = Trim(REX.Replace(StringIn, vbNullString))
End Function

Hope that helps,

Mark

[GTO]

Greetings,

PResuming we can count on the hyphen, maybe:
Option Explicit

Enum eSheetOrFile
Namingfile = 1
NamingSheet = 2
End Enum

Sub CombineAreaFiles()
Dim _
FSO As Object, _
fsoFol As Object, _
fsoFil As Object, _
strFol As String, _
strFil As String, _
WB As Workbook, _
WBNew As Workbook, _
wks As Worksheet

'// Create a reference to the FileSystemObject //
Set FSO = CreateObject("Scripting.FileSystemObject")

'// I'm working in 2000, chose GetOpenFilename to get the fullname. //
strFil = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls),*.xls", _
Title:="Pick a file in the folder...", _
MultiSelect:=False)

'// Rip the fullpath //
strFol = FSO.GetParentFolderName(strFil) & "\"

'// Bail here if something goofy (user didn't choose) //
If FSO.FolderExists(strFol) Then
Set fsoFol = FSO.GetFolder(strFol)
Else
MsgBox "No legit folder"
Exit Sub
End If

'// See function//
strFil = Area_Ret(strFil)

'// Ensure dest wb doesn't already exist //
If Not FSO.FileExists(ThisWorkbook.Path & "\" & strFil & ".xls") Then
Set WBNew = Workbooks.Add(xlWBATWorksheet)
WBNew.SaveAs Filename:=ThisWorkbook.Path & "\" & strFil & ".xls"
Else
MsgBox "Wokbook already exists...", vbOKOnly, vbNullString
Exit Sub
End If

'// For ea file in chosen folder... //
For Each fsoFil In fsoFol.Files

'// If file is wb AND filename has match (ie - North, South, whatever is //
'// hyphen) to strFil, then... //
If fsoFil.Type = "Microsoft Excel Worksheet" _
And Area_Ret(fsoFil.Name) = strFil Then

'// Set references to the opening wb and sheet1 thereof, //
Set WB = Workbooks.Open(Filename:=strFol & fsoFil.Name, _
ReadOnly:=True)
Set wks = WB.Worksheets(1)

'// Copy first sheet from source to after last sheet in dest (ThisWorkbook)//
'// close source, and re-set reference to copied sheet in dest. //
With WBNew
wks.Copy After:=.Worksheets(.Worksheets.Count)
WB.Close SaveChanges:=False
Set wks = .Worksheets(.Worksheets.Count)
End With

'// Using the filename of the source wb, if such a sheetname does not //
'// exist in dest, AND, name is legal (pobably overkill), then rename //
'// copied sheet. //
If Not ShExists(Left(fsoFil.Name, InStrRev(fsoFil.Name, ".") - 1)) _
And IsLegalName(Left(fsoFil.Name, InStrRev(fsoFil.Name, ".") - 1)) Then
wks.Name = Left(fsoFil.Name, Application.Min(InStrRev(fsoFil.Name, ".") - 1, 31))
End If
End If
Next

Application.DisplayAlerts = False
WBNew.Worksheets(1).Delete
WBNew.Close True
Application.DisplayAlerts = True


End Sub

Function ShExists(ShName As String, _
Optional WB As Workbook, _
Optional IgnoreCase As Boolean = False) As Boolean
Dim wks As Worksheet

If WB Is Nothing Then
Set WB = ThisWorkbook
End If

If IgnoreCase Then
On Error Resume Next
Set wks = Worksheets(ShName)
On Error GoTo 0

ShExists = CBool(Not wks Is Nothing)
Else
On Error Resume Next
ShExists = CBool(WB.Worksheets(ShName).Name = ShName)
On Error GoTo 0
End If
End Function

Function IsLegalName(StringInput As String, _
Optional NameType As eSheetOrFile = NamingSheet) As Boolean

If NameType = Namingfile Then
IsLegalName = CBool(Not StringInput Like "*[.""/\[:;=,]*" _
And Not StringInput Like "*]*")
Else
IsLegalName = CBool(Not StringInput Like "*[:\/?*[]*" _
And Not StringInput Like "*]*")
End If
End Function

Function Area_Ret(StringIn As String) As String 'REX As RegExp,
Static REX As RegExp

'// Use a Static variable, so we only have to create the object once (thanks to XLD)//
If REX Is Nothing Then
Set REX = CreateObject("VBScript.RegExp")
'// True so that we'll .Replace all occurrences in the string that match the //
'// Pattern. //
REX.Global = True
'// I am definitely baby-stepping RegExp's, but I think: //
'// Anything other than newline (zero to unlimited len), followed by one hyphen,//
'// followed by zero to unlimited spaces, followed by a word boundary. //
'// OR (alternation) //
'// One dot, followed by three to four letters (ie - the extension). //
'// to unlimited spaces, followed by
REX.Pattern = ".*-\ *\b|[.][a-z]{3,4}"
End If

'// Return the string with matches replaced by nullstring(s) //
Area_Ret = Trim(REX.Replace(StringIn, vbNullString))
End Function

Hope that helps,

Mark

[DAMAN]

Hi Mark

Yes the assumption is right, you can count on the hyphen. I tried to run it but I get a "compile error:user type not defined" next to the line Static REX As RegExp (the last bit of code).

Sorry AussieBear you are right I should of been more clear. Thanks for your help in advance - the only rule is that the compositive file should contain all files with the last bit of the filename after the hypen.

[GTO]

...I tried to run it but I get a "compile error:user type not defined" next to the line Static REX As RegExp (the last bit of code).

Oops... Not sure if you are familiar with early vs. late binding, but you can find info in vba help. I wrote it early-bound, and changed to late-bound before posting, but missed that one.

Change:

Static REX As RegExp
to...

Static REX As Object

Sorry about that.

Mark

[DAMAN]

Hi Mark

Its unfortunately its not working, it executes but nothing happens. Hate taking up your time with this, I can start trying to do it manually - ie putting into similar files into one file and running your initial code.

If you have any luck getting it to work please let me know, it is definately needed in my office. Thanks.

Cheers

[GTO]

Hi Mark

Its unfortunately its not working, it executes but nothing happens. Hate taking up your time with this, I can start trying to do it manually - ie putting into similar files into one file and running your initial code.

If you have any luck getting it to work please let me know, it is definately needed in my office. Thanks.

Cheers

Hi Daman,

I'm certainly not beyond botching a bit of code now and then, but I tested against wb's listed below.

Does this look similar to how the actual files are named?

If yes, attach a wb with the code as you have applied it.

Hope to help,

Mark

[DAMAN]

Hi Mark

All the files are exactly like the first one Jack Sales - North

Cheers

[DAMAN]

Soryy Mark, Workbook Attached

Cheers

[GTO]

After running 'CombineAreaFiles', look for North.xls in the same folder you have Macro.xls saved in.

[DAMAN]

I have to give myself an uppercut, that is brilliant, thank you very much. I am very very new to VBA, this is great.

[GTO]

I have to give myself an uppercut, that is brilliant, thank you very much. I am very very new to VBA, this is great.

No self injuries! Take it out on the PC!:igiveup:

I doubt anything I write would qualify as brilliant, but thank you and of course, happy to help:beerchug: .

If solved, you can mark as such under Thread Tools atop your first post. This keeps others from rechecking to see if help is still needed.

Thanks,

Mark

PS - A thanks to Bob Phillips. Static is a nice tidbit to learn effective use of!