Expert: Tom Ogilvy - 11/8/2009

Question
Dear Tom,

I am always happy to have your kind support. Your help, comments and suggestions are really useful.
I would like to ask your help to solve my present problem, if You have a little time.
I managed to do most of the parts (gathering info from the net and combining changing it to the present code) but some points remained unsolved.

I have a main folder with subfolders that have lot more subfolders with many xls files.
What I managed to do at present is to pick up files containing ASHA and SQ (I need these to be differentiated from the rest of the files) somewhere in their file name and separate/save sheets of these xls books by sheet name as file name to Prac folder.

The only problem remained, that some sheets belong together and I have no idea how to save them together.
These sheets are common in the first 10 digits (identical number) in their sheet name.
For example:
Code works when only one sheet belongs to a case: 2008091234
Need help when several (1-8) sheets belong to one case:
Pattern one:
2008091235(1), 2008091235(2), 2008091235(3) (file name should be 2008091235 after execution of the macro, sheet name can remain like these in the book after the separation)
Another pattern:
2008091236_1, 2008091236_2, 2008091236_3 (file name should be 2008091236 after execution of the macro, sheet names can remain like these in the book after the separation)

As I mentioned, the common in the sheets for one case is the first 10 digits.
I hope You can advice me a solution to save these sheets belonging to one case with the 10 digit ID number as file name.

I hope could explain my problem clearly.

I would appreciate your kind advice, suggestions, assistance.

Best wishes,

attis

the code:
Sub ExecAllSh()

Dim sPath As String
Dim sFile As String
Dim sDir As String
Dim oWB As Workbook
Dim i1 As Long
Dim iMax As Long
Dim wks As Worksheet
Dim newWks As Worksheet

On Error GoTo Err_Clk

sPath = "C:\Documents and Settings\attis\My Documents\EVALUATION\" ' Your Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

sDir = Dir$(sPath & "*ASHA*SQ*.xls", vbNormal)
Do Until LenB(sDir) = 0
Set oWB = Workbooks.Open(sPath & sDir)

For Each wks In ActiveWorkbook.Worksheets
wks.Copy 'to a new workbook
Set newWks = ActiveSheet

With newWks
Application.DisplayAlerts = False
.Parent.SaveAs Filename:="C:\Documents and Settings\attis\My Documents\Prac\" & .Name, _
FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
.Parent.Close SaveChanges:=False
End With

Next wks

oWB.Save
oWB.Close False
sDir = Dir$
Loop

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub


Answer
attis,

I can't test the specific code offered because I don't even remotely have any situation similar, but I tested the basic concept of and it worked for me.  So this may take some work on your part.  But the approach is to build a collection with a key of the first 10 digits of each file as you save it (the actual value in the collection is the sheet name which is used as the filename).  Then, before saving the next file, check if the first 10 digits of its eventual name already exist.  If so, then get the filename used from the collection and save it in that file.  Otherwise save it as you were doing.  


Sub ExecAllSh()

Dim sPath As String
Dim sFile As String
Dim sDir As String
Dim oWB As Workbook
Dim i1 As Long
Dim iMax As Long
Dim wks As Worksheet
Dim newWks As Worksheet
Dim sDest As String
Dim nodupes As New Collection
Dim sName As String
Dim sKey As String
Dim bk As Workbook
Dim bDup As Boolean

sDest = "C:\Documents and Settings\attis\My Documents\Prac\"

On Error GoTo Err_Clk

sPath = "C:\Documents and Settings\attis\My Documents\EVALUATION\" ' Your Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

sDir = Dir$(sPath & "*ASHA*SQ*.xls", vbNormal)
Do Until LenB(sDir) = 0
Set oWB = Workbooks.Open(sPath & sDir)

For Each wks In ActiveWorkbook.Worksheets
sKey = Left(wks.Name, 10)
On Error Resume Next
 nodupes.Add wks.Name, sKey
 If Err.Number <> 0 Then
   sName = nodupes(sKey)
   bDup = True
 Else
   sName = wks.Name
   bDup = False
 End If
On Error GoTo Err_Clk

If Not bDup Then
wks.Copy 'to a new workbook
Set newWks = ActiveSheet
With newWks
Application.DisplayAlerts = False
.Parent.SaveAs Filename:="C:\Documents and Settings\attis\My Documents\Prac\" & .Name, _
FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
.Parent.Close SaveChanges:=False
End With
Else
 Set bk = Workbooks.Open(sDest & sName & ".xls")
 wks.Copy After:=bk.Worksheets(bk.Worksheets.Count)
 bk.Close SaveChanges:=True
End If

Next wks

oWB.Save
oWB.Close False
sDir = Dir$
Loop

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub

--
Regards,
Tom Ogilvy