Macro won't break links to external spread sheet

mdetroyer

New Member
Joined
May 12, 2016
Messages
3
I have a template that I update weekly with new data. I've written code to create a "report" for broad distribution each week from this template. The report creation works great except for the fact that the links to the template and another workbook that i use as an image databse won't break. I've run into problems with the links to the workbook that has the images because I am using named ranges and lookup formulas in the named ranges to populate the template. Any thoughts?


Code:
Sub NewReport()
Dim Wb1 As Workbook
Dim wb2 As Workbook
Dim RN As String
RN = Range("d1").Value
Dim WMWK As String
WMWK = Sheets("fineline name").Range("j4").Value




With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With


Set Wb1 = ActiveWorkbook


Set wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name, Wb1.Sheets(3).Name, Wb1.Sheets(4).Name)).Copy Before:=wb2.Sheets(1)
wb2.Sheets(wb2.Sheets.Count).Delete
wb2.SaveAs ThisWorkbook.Path & "\" & RN & " WK " & WMWK, FileFormat:=52
Call BreakLinks(wb2)


wb2.Close savechanges:=True
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With


End Sub
Sub BreakLinks(ByRef wb2 As Workbook)
Dim LoseLinks As Variant
On Error Resume Next
LoseLinks = wb2.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(LoseLinks) Then

For i = 1 To UBound(LoseLinks)
wb2.BreakLink _
Name:=LoseLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
Code:
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

mdetroyer

New Member
Joined
May 12, 2016
Messages
3
Sorry guys. Here is the code posted correctly.
Code:
[COLOR=#333333]Sub NewReport()[/COLOR]
[COLOR=#333333]Dim Wb1 As Workbook[/COLOR]
[COLOR=#333333]Dim wb2 As Workbook[/COLOR]
[COLOR=#333333]Dim RN As String[/COLOR]
[COLOR=#333333]RN = Range("d1").Value[/COLOR]
[COLOR=#333333]Dim WMWK As String[/COLOR]
[COLOR=#333333]WMWK = Sheets("fineline name").Range("j4").Value[/COLOR]




[COLOR=#333333]With Application[/COLOR]
[COLOR=#333333].ScreenUpdating = False[/COLOR]
[COLOR=#333333].DisplayAlerts = False[/COLOR]
[COLOR=#333333].EnableEvents = False[/COLOR]
[COLOR=#333333]End With[/COLOR]


[COLOR=#333333]Set Wb1 = ActiveWorkbook[/COLOR]


[COLOR=#333333]Set wb2 = Application.Workbooks.Add(1)[/COLOR]
[COLOR=#333333]Wb1.Sheets(Array(Wb1.Sheets(1).Name, Wb1.Sheets(2).Name, Wb1.Sheets(3).Name, Wb1.Sheets(4).Name)).Copy Before:=wb2.Sheets(1)[/COLOR]
[COLOR=#333333]wb2.Sheets(wb2.Sheets.Count).Delete[/COLOR]
[COLOR=#333333]wb2.SaveAs ThisWorkbook.Path & "\" & RN & " WK " & WMWK, FileFormat:=52[/COLOR]
[COLOR=#333333]Call BreakLinks(wb2)[/COLOR]


[COLOR=#333333]wb2.Close savechanges:=True[/COLOR]
[COLOR=#333333]With Application[/COLOR]
[COLOR=#333333].ScreenUpdating = True[/COLOR]
[COLOR=#333333].DisplayAlerts = True[/COLOR]
[COLOR=#333333].EnableEvents = True[/COLOR]
[COLOR=#333333]End With[/COLOR]


[COLOR=#333333]End Sub[/COLOR]
[COLOR=#333333]Sub BreakLinks(ByRef wb2 As Workbook)[/COLOR]
[COLOR=#333333]Dim LoseLinks As Variant[/COLOR]
[COLOR=#333333]On Error Resume Next[/COLOR]
[COLOR=#333333]LoseLinks = wb2.LinkSources(Type:=xlLinkTypeExcelLinks)[/COLOR]
[COLOR=#333333]On Error GoTo 0[/COLOR]
[COLOR=#333333]If Not IsEmpty(LoseLinks) Then[/COLOR]

[COLOR=#333333]For i = 1 To UBound(LoseLinks)[/COLOR]
[COLOR=#333333]wb2.BreakLink _[/COLOR]
[COLOR=#333333]Name:=LoseLinks(i), _[/COLOR]
[COLOR=#333333]Type:=xlLinkTypeExcelLinks[/COLOR]
[COLOR=#333333]Next i
[/COLOR]End If

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,099,737
Messages
5,470,444
Members
406,699
Latest member
perfectioncts

This Week's Hot Topics

Top