Split Workbook part 2

C

Cheryl

Tom: thanks for the code. It's generating some errors in
that
Set bk = Workbooks(sCheryl) always says subscript out of
range and
ActiveWorkbook.SaveAs Filename:= ThisWorkbook.Path & "\" &
sCheryl & ".xls" says filename already exists, chose
another name or close the existing workbook when it tries
to create a workbook that already exists.

If bk Is Nothing Then is always equating to Nothing so I
believe that is why I'm getting the above error message.

Thu I understand what the code is doing as it involves
arrays and Collections it is a bit above my abilities.
I've spent the better part of the last couple of days
attempting changes but no luck... any help would be
appreciated.
 
T

Tom Ogilvy

the code I wrote was

On Error Resume Next
Set bk = Workbooks(sCheryl)
On Error GoTo 0


If that is the code you are using, you need to go to the VBE and in
tools=>Options , General Tab make sure have have

Break on Unhandled Errors

checked.

In the code I wrote, at the top it has

Application.DisplayAlerts = False


with this in effect, you would not get the prompt that the file already
exists.

the bk variable is to determine if the workbook exists and if it is open or
not. Since you would have multiple worksheets being placed in the same
workbook, after the first time it is created, it should still be open and
then only the sheet needs to be copied to the existing workbook.
 
T

Tom Ogilvy

OK, I see there is a problem based on a particular Windows Setting. Also,
there was another problem that the code depended on the master workbook
being active at the beginning of the loop. I have corrected these and
tested the code and it ran for me:

Option Explicit
Public Sub SpitWorkbook()
Dim W As Worksheet
Dim bk As Workbook
Dim sCheryl As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each W In Worksheets
sCheryl = W.Range("B2").Value
If InStr(1, sCheryl, ".xls", _
vbTextCompare) = 0 Then
sCheryl = sCheryl & ".xls"
End If
Set bk = Nothing
On Error Resume Next
Set bk = Workbooks(sCheryl)
On Error GoTo 0
If bk Is Nothing Then
W.Copy
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
ThisWorkbook.Path & "\" & sCheryl
Else
W.Copy After:=bk.Worksheets( _
bk.Worksheets.Count)
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
bk.Save
End If
Next W
For Each bk In Application.Workbooks
If bk.Name <> ThisWorkbook.Name Then
bk.Close Savechanges:=False
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Top