Copy Worksheets break links - vba

Question

I have the below 2 subs in VBA which perform 2 different but similar tasks. One allows you to selects sheets from a Workbook using a checkbox popup and then copies these sheets into a new blank Workbook. The other allows you to manually populate a list of names of the sheets you want to copy (i.e. setup a "batch" of sorts) on a sheet and then copy all the sheets across into a new blank Workbook in a similar fashion to the first.
The problem I am having is - with the first sub I am able to break links after copying into the new Workbook, but with the second sub I am not able to break links. I think it has to do with a number of defined names within the original Workbook, as if you "Move or Copy/Create a Copy" manually, you are able to break the links.
Is there any code I can add to the below (onto both subs if possible) which will automatically break all links in the new Workbook to the old one? Or at least, is it possible to amend the second sub so that it copies across in a similar fashion to the first one which will then allow me to break links manually?
Sub CopySelectedSheets()
'1. Declare variables
Dim I As Integer
Dim SheetCount As Integer
Dim TopPos As Integer
Dim lngCheckBoxes As Long, y As Long
Dim intTopPos As Integer, intSheetCount As Integer
Dim intHor As Integer
Dim intWidth As Integer
Dim intLBLeft As Integer, intLBTop As Integer, intLBHeight As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
Dim firstSelected As Boolean
' Dim wb As Workbook
' Dim wbNew As Workbook
' Set wb = ThisWorkbook
' Workbooks.Add ' Open a new workbook
' Set wbNew = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False
'2. Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'3. Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'4. Add the checkboxes
TopPos = 40
For I = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(I)
'Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next I
'6. Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'7. Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to generate"
End With
'Change tab order of OK and Cancel buttons
'so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'9. Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
If firstSelected Then
Worksheets(CB.Caption).Select Replace:=False
Else
Worksheets(CB.Caption).Select
firstSelected = True
End If
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
Next
ActiveWindow.SelectedSheets.Copy
Else
MsgBox "No worksheets selected"
End If
End If
' Delete temporary dialog sheet (without a warning)
'' Application.DisplayAlerts = False
'' Printdlg.Delete
' Reactivate original sheet
'' CurrentSheet.Activate
'' wsStartSheet.Activate
'10.Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'11.Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
Application.DisplayAlerts = True
End Sub
Sub CopySpecificSheets()
'1. Declare Variables
Dim myArray() As String
Dim myRange As Range
Dim Cell As Range
Dim OldBook As String
Dim newBook As String
Dim a As Long
'2. Set Range of Lookup
Set myRange = Sheets("Report Batch").Range("A2:A40")
OldBook = ActiveWorkbook.Name
'3. Generate Array of Sheet Names removing Blanks
For Each Cell In myRange
If Not Cell = "" Then
a = a + 1
ReDim Preserve myArray(1 To a)
myArray(a) = Cell
End If
Next
'4. Copy Array of Sheets to new Workbook
For a = 1 To UBound(myArray)
If a = 1 Then
Sheets(myArray(a)).Copy
newBook = ActiveWorkbook.Name
Workbooks(OldBook).Activate
Else
Sheets(myArray(a)).Copy After:=Workbooks(newBook).Sheets(a - 1)
Workbooks(OldBook).Activate
End If
Next
End Sub

Answer 1

Try something like this:
Sub CopySpecificSheets()
'1. Declare Variables
Dim rngData As Range
Dim arrData As Variant
Dim arrSheets() As String
Dim lSheetCount As Long
Dim i As Long
Dim j As Long
'2. Initialize variables
Set rngData = Sheets("Report Batch").Range("A2:A40")
arrData = rngData.Value
lSheetCount = WorksheetFunction.CountA(rngData)
ReDim arrSheets(lSheetCount - 1)
'3. Fill the array with non blank sheet names
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) <> vbNullString Then
arrSheets(j) = arrData(i, 1)
j = j + 1
End If
' early break if we have all the sheets
If j = lSheetCount Then
Exit For
End If
Next i
'4. Copy the sheets in one step
Sheets(arrSheets).Copy
End Sub
Thanks

Answer 2

This isn't tested, but I think if you add in a subroutine to your source workbook VBA code like this:
Sub BreakLinks(ByRef wb As Workbook)
Dim Links As Variant
Dim i As Long
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
And then call it after you copy the sheets to the new workbook
Call BreakLinks(newBook)
That should achieve the desired effect of severing those links. Just be sure the links are broken to any sort of Save or SaveAs operation so that the broken links are maintained.