Creating Individual Workbooks

As useful as this macro might be, I've often wondered whether a better approach would be to make X copies of the workbook where X is the number of worksheets. Each workbook copy would then remove all worksheets except the one which is supposed to remain.

Why do this? To preserve the macros and special formatting that might otherwise be lost.

Hi Alex
Thanks, I have it working now. ( I had to Dim a couple of variables ( nmUseAddrs As String , i As Long ) as I use Option Explicit ).
Alan

Hello Alan, I tend to reuse a lot of code and stick it in a Library module, so I forgot that I called the code below. (Your point 2). Sorry about the omission.
PS: I use selected sheets in my main macro rather than all sheets, it makes it easier when testing if nothing else.

Function FindAddress(FindString, Optional Whole_Part)
' Find a supplied text in the active worksheet and return the address information.
If Whole_Part = "" Then Whole_Part = xlWhole
On Error GoTo ErrorHandling

FindAddress = Cells.Find(What:=FindString, After:=Range("A1"), LookIn:=xlFormulas, LookAt _
:=Whole_Part, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Address

Exit Function:

ErrorHandling:

FindAddress = ""

End Function

Hi Alex B,
Thanks for sharing. I tried your codes..
( _1) End Function was missing on your first Function )

_2) I error at
FindAddress(

_...........
This is the code I tried. ( I am using XL 2007 and saving as .xlsm )

' https://excelribbon.tips.net/T012273_Creating_Individual_Workbooks.html
Sub BreakItUp()
Dim Ws As Worksheet
Dim NFName As String, WBPath As String
Let WBPath = ThisWorkbook.Path & "\" ' "C:\"
For Each Ws In ActiveWorkbook.Worksheets
Ws.Copy ' This effectively makes a copy File with one Worksheet in it, Ws
' NFName = WBPath & Ws.Name & ".xls"
' ActiveWorkbook.SaveAs Filename:=NFName, FileFormat:=xlNormal, CreateBackup:=False
Let NFName = WBPath & Ws.Name & ".xlsm"
ActiveWorkbook.SaveAs Filename:=NFName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Call DeleteBadRefs_and_Links(ActiveWorkbook)
Call BreakLinks(ActiveWorkbook)
ActiveWindow.Close
Next
End Sub
Function DeleteBadRefs_and_Links(wkb As Workbook)
Dim nm As Name
For Each nm In wkb.Names
If InStr(1, nm.RefersTo, "#REF!") > 0 Or InStr(1, nm.RefersTo, "[") > 0 Then
Let nmUseAddrs = FindAddress(FindString:=nm.Name, Whole_Part:=xlPart)
If nmUseAddrs <> "" Then
With wkb.Sheets(1).Range(nmUseAddrs)
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
End If
nm.Delete
End If
Next nm
End Function
Function BreakLinks(wkb As Workbook)
Dim Links As Variant
Links = wkb.LinkSources(Type:=xlLinkTypeExcelLinks)
If Not (IsEmpty(Links)) Then
For i = 1 To UBound(Links)
wkb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Function

There is quite a bit more you could add to this. To start with it would be safer to save the spreadsheet as xlsx so that you at least don't hit the xls row limit issue when you save it.

From my base code I make 2 function calls to:-
- replace range names linked to the original s/sheet with values and then delete the range name
- Break the Links to the original s/sheet replacing it with values.
The functions I am using are below.

Function DeleteBadRefs_and_Links(wkb As Workbook)

Dim nm As Name

For Each nm In wkb.Names
If InStr(1, nm.RefersTo, "#REF!") > 0 _
Or InStr(1, nm.RefersTo, "[") > 0 Then

nmUseAddrs = FindAddress(FindString:=nm.Name, Whole_Part:=xlPart)

If nmUseAddrs <> "" Then
With wkb.Sheets(1).Range(nmUseAddrs)
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
End If

nm.Delete
End If
Next nm


Function BreakLinks(wkb As Workbook)

Dim Links As Variant
Links = wkb.LinkSources(Type:=xlLinkTypeExcelLinks)

If Not (IsEmpty(Links)) Then
For i = 1 To UBound(Links)
wkb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If

End Function