Copy Worksheet to a new Workbook while breaking links (to other sheets) but keeping values from the links. Save new Workbook as .xlsx

vintage88

New Member
Joined
Jan 28, 2021
Messages
5
Office Version
  1. 2013
Platform
  1. Windows
I have a Workbook that contains several sheets, I need to save Sheet1 as standalone Workbook using VBA.
The problem is that when I use " ws.SaveAs newFolderFullName FileFormat:=51 " it saves the original Workbook as it is.

Another problem is that the Sheet1 contains formulas, and data that is pulled from other sheets if the original Workbook. Therefore I need to save new Workbook and break the links so that the data from formulas is saved as data, not the formulas referring to another (original) Workbook)

Would be also useful is the same approach applies to images.
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,170
Office Version
  1. 2016
Platform
  1. Windows
See if this solve all your problem. This probably would not removing all links but see if it is suffice to your need.

 

vintage88

New Member
Joined
Jan 28, 2021
Messages
5
Office Version
  1. 2013
Platform
  1. Windows
See if this solve all your problem. This probably would not removing all links but see if it is suffice to your need.

Seems like it makes no effect on the output, its still has links to the original Workbook :(
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,170
Office Version
  1. 2016
Platform
  1. Windows
There are many types of links.It could be just formula, named range. You need a routine that will find for specific pattern for these links. I created mine based on what I needed.

You can detect characters like ! or ] . I found a long VBA with supporting Functions that said can remove and it it cannot, it will identify and tell you where link locations are. I believe this will solve your problem. I did not try this one anyway ;)

VBA Code:
'
' *********************************************************************
'  TITLE:   EXTERNAL LINK UTILITY
'  PURPOSE: Finds all external links in a workbook, including the very
'           hard to find ones. Cleans some links automatically and
'           provides instructions for how to manually remove the others.
'  NOTES:   This can take 2 or 3 minutes to run if a workbook contains
'           a large number of external links.
'  HOW TO:  Open the affected workbook and run this macro.
'  AUTHOR:  jramm
'           https://stackoverflow.com/questions/48337861/removing-external-links
' *********************************************************************
'

' GLOBAL VARIABLES
' ====================
Dim g_ResultBook As Workbook

' MAIN SUB
' ====================
Sub ExternalLinkUtility()
    Excel.Application.ScreenUpdating = False

    ReportExternalLinks ActiveWorkbook

    Excel.Application.ScreenUpdating = True
    If Not g_ResultBook Is Nothing Then
        g_ResultBook.Activate 'bring the result book into view if it's not already.
        Set g_ResultBook = Nothing
    End If
End Sub


'FUNCTION: OutputLinkInfo
'PARAMETERS:
'    wbk - full workbook filepath (Workbook.FullName)
'    wsh - worksheet name (Worksheet.Name)
'    adr - cell address string (A1) or an empty string ("") to omit hyperlink to issue location
'    loc - friendly name we want reader to see (such as "Cell B4" or "My Cool Chart")
'    fml - external link formula that is causing the problem
'    txt - fix instructions (or other notes)
Function OutputLinkInfo(typ As String, wbk As String, wsh As String, loc As String, adr As String, fml As String, txt As String)
    Static resultLn As Long
    'first time called: Create result workbook
    '=========================================
    If g_ResultBook Is Nothing Then
        Set g_ResultBook = Workbooks.Add
        With g_ResultBook.Worksheets.Item(1)
            'title row
            .Range("A1").Value = "External Link Report"
            .Range("A1").Font.Bold = True
            .Range("A1").Font.Size = 18
            .Range("A1:F1").Interior.Color = RGB(0, 112, 192)
            .Range("A1:F1").Font.Color = RGB(255, 255, 255)
            'column headers row
            .Range("A2").Value = "Type"
            .Range("B2").Value = "Workbook"
            .Range("C2").Value = "Worksheet"
            .Range("D2").Value = "Location"
            .Range("E2").Value = "Reference"
            .Range("F2").Value = "Fix Instructions"
            .Range("A2:F2").Interior.Color = RGB(221, 235, 247)
            .Range("A2:F2").Font.Bold = True
            'set column widths
            .Columns("A").ColumnWidth = 22
            .Columns("B").ColumnWidth = 15
            .Columns("C").ColumnWidth = 28
            .Columns("D").ColumnWidth = 28
            .Columns("E").ColumnWidth = 60
            .Columns("F").ColumnWidth = 60
            'add filter
            .Range("A2:F2").AutoFilter
        End With
        resultLn = 2
    End If

    'every time called: Write single result line using the passed parameters
    '=======================================================================
    resultLn = resultLn + 1

    With g_ResultBook.Worksheets.Item(1)
        .Range("A" & resultLn).Value = typ
        .Range("B" & resultLn).Value = Dir(wbk) 'Dir gets us only the filename from the end of the full path
        .Range("C" & resultLn).Value = wsh
        .Range("D" & resultLn).Value = loc
        If (Len(adr) > 0) And (Len(Dir(wbk)) > 0) Then
            .Hyperlinks.Add .Range("D" & resultLn), wbk, "'" & wsh & "'!" & adr, "Jump to this issue", loc
        End If
        .Range("E" & resultLn).Value = "'" & fml 'prepend apostrophe to force formula to display as plain text
        .Range("F" & resultLn).Value = txt
    End With

End Function


'FUNCTION: OutputLinkInfo
'PARAMETERS:
'    wkbk - workbook to check for external links
Function ReportExternalLinks(wkbk As Excel.Workbook) As String()
    Dim wksht As Excel.Worksheet
    Dim cell As Excel.Range
    Dim numLinks As Integer
    Dim fml As String
    Dim r As Range
    numLinks = 0 'Note that numLinks causes a Runtime error if this macro detects >32,768 external links. The
                 'macro should probably be updated at some point to more gracefully handle this situation, but
                 'I haven't gotten around to it because that scenario is very unlikely.

'``````````````````````````````````````````````````````````
'WORKSHEET-LEVEL CHECKS are performed in the following loop
',,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,

    For Each wksht In wkbk.Worksheets

    ' Search for external links in cell formulas
    ' ==========================================
        For Each cell In wksht.UsedRange.Cells
            On Error Resume Next
            fml = cell.Formula
            If Err.Number <> 0 Then
                Err.Clear
            ElseIf (InStr(fml, "[") <> 0) And (InStr(fml, ".xl") <> 0) Then
                ' the ".xl" check was added to avoid false positives when a user enters brackets in the cell
                ' (for example, if the cell text is "[Test]"). However, this additional check probably causes
                ' this part of the macro to miss external data connections, which won't have .xl in their name
                    On Error GoTo 0
                    numLinks = numLinks + 1
                    OutputLinkInfo "Cell Formula", _
                                   wkbk.FullName, _
                                   wksht.Name, _
                                   "Cell " & cell.Address(False, False), _
                                   cell.Address, _
                                   fml, _
                                   "Delete the formula from this cell."
            End If
            On Error GoTo 0
        Next cell

    ' Search for external links in shapes
    ' ===================================
        Dim shp As Shape
        Dim subshp As Shape
        For Each shp In wksht.Shapes
            On Error Resume Next
            fml = shp.DrawingObject.Formula 'will throw an error whenever the shape doesn't have a formula
            If Err.Number <> 0 Then
                Err.Clear
            ElseIf InStr(fml, "[") <> 0 Then
                On Error GoTo 0
                numLinks = numLinks + 1
                OutputLinkInfo "Shape/Object", _
                               wkbk.FullName, _
                               wksht.Name, _
                               shp.Name, _
                               shp.TopLeftCell.Address & ":" & shp.BottomRightCell.Address, _
                               fml, _
                               "Select the shape. The shape's formula appears in the Excel formula bar. Delete the external reference."
            End If
            On Error GoTo 0

            'iterate subshapes for any groups (supposedly this should catch all no matter how nested they are, but I only tested normal groups 1-level deep)
            If shp.Type = msoGroup Then
                For Each subshp In shp.GroupItems
                    On Error Resume Next
                    fml = subshp.DrawingObject.Formula
                    If Err.Number <> 0 Then
                        Err.Clear
                    ElseIf InStr(fml, "[") <> 0 Then
                        On Error GoTo 0
                        numLinks = numLinks + 1
                        OutputLinkInfo "Shape/Object", _
                                       wkbk.FullName, _
                                       wksht.Name, _
                                       subshp.Name & " (part of shape group '" & shp.Name & "')", _
                                       subshp.TopLeftCell.Address & ":" & subshp.BottomRightCell.Address, _
                                       fml, _
                                       "Select the shape. The shape's formula appears in the Excel formula bar. Delete the external reference."
                    End If
                    On Error GoTo 0
                Next subshp
            End If
        Next shp

    ' Search for external links in conditional formatting
    ' ===================================================
    ' NOTE: external links in conditional formatting (CF) are some of the weirdest. You can open the CF window
    ' for the cell in Excel, and you won't see any external links in the formula, so there's no way to manually
    ' fix it besides deleting the CF from the cell entirely or copy-and-pasting a valid CF cell over the top of the
    ' affected cell to replace it. I have seen workbooks with hundreds of CF external links, and you can open the
    ' affected cell's CF rule in Excel, and then open a nearby CF rule that does not have an external link, and they
    ' look identical in the CF window in Excel (even though .Formula1 and other .Formula properties are not the
    ' same when accessed from VBA) I have written some code to automatically fix very specific CF rules with
    ' external links, but it would be very difficult to write generic code that could fix any CF rule that has an
    ' external link. There are far too many CF conditions, operators, formulas, and other details and no simple way
    ' to determine how to "fix" them programmatically.
        Dim cForm As Object
        For Each cForm In wksht.Cells().FormatConditions
            On Error Resume Next
            fml = cForm.Formula1
            If Err.Number <> 0 Then
                Err.Clear
            ElseIf InStr(fml, "[") <> 0 Then
                On Error GoTo 0
                numLinks = numLinks + 1
                OutputLinkInfo "Conditional Formatting", _
                               wkbk.FullName, _
                               wksht.Name, _
                               "Cell " & cForm.AppliesTo.Address(False, False), _
                               cForm.AppliesTo.Address, _
                               fml, _
                               "Select the cell and open the conditional formatting window (Home > Conditional Formatting). " & _
                               "Delete the external link from the conditional formatting formula if you see it. In some cases, " & _
                               "you cannot see external links in the conditional formatting formula. In that scenario, either " & _
                               "delete the conditional formatting from the cell, or copy-and-paste a different cell's valid " & _
                               "conditional formatting over the top of the affected cell in order to fix the issue."
            End If
            On Error GoTo 0
        Next cForm

    ' Search for external links in charts
    ' ===================================
        Dim cht As Excel.ChartObject
        Dim srs As Excel.Series
        Dim chartName As String
        For Each cht In wksht.ChartObjects
            For Each srs In cht.Chart.SeriesCollection
                On Error Resume Next
                fml = srs.Formula
                If Err.Number <> 0 Then
                    Err.Clear
                ElseIf InStr(fml, "[") <> 0 Then
                    On Error GoTo 0
                    numLinks = numLinks + 1
                    If cht.Chart.HasTitle Then
                        chartName = cht.Chart.ChartTitle.Text 'This is the better option when available
                    Else
                        chartName = cht.Chart.Name & " (" & cht.Name & ")"
                    End If
                    OutputLinkInfo "Chart", _
                                   wkbk.FullName, _
                                   wksht.Name, _
                                   chartName, _
                                   cht.TopLeftCell.Address & ":" & cht.BottomRightCell.Address, _
                                   fml, _
                                   "Right-click the chart > Select Data... Click Edit on each series in the Legend Entries " & _
                                   "(Series) list. Remove the external link in the formulas you find there."
                End If
                On Error GoTo 0
            Next srs
        Next cht

    ' Search for external links in pivot tables
    ' =========================================
        Dim pvt As Excel.PivotTable
        For Each pvt In wksht.PivotTables
            On Error Resume Next
            fml = pvt.SourceData
            If Err.Number <> 0 Then
                Err.Clear
            ElseIf InStr(fml, "[") <> 0 Then
                On Error GoTo 0
                numLinks = numLinks + 1
                OutputLinkInfo "PivotTable", _
                               wkbk.FullName, _
                               wksht.Name, _
                               pvt.Name, _
                               pvt.TableRange1.Address, _
                               fml, _
                               "Click the PivotTable. In the Excel ribbon, go to Analyze > Change Data Source. " & _
                               "Delete the external link from the formula you find there."
            End If
            On Error GoTo 0
        Next pvt

    ' Search for external links in data validation
    ' ============================================
        'NOTE: this section of the code can take a few minutes to run on workbooks where the data validation
        'was applied to an entire column, because it iterates through every cell in the column separately.
        'Probably there's a smarter way to improve the performance of this part of the macro for such scenarios,
        'but I haven't gotten around to trying to improve it.
        Dim dataValExtLinkRanges As Object
        Dim key As Variant
        Set dataValExtLinkRanges = CreateObject("Scripting.Dictionary")

        'first, iterate over cells with data validation and UNION together the cells associated with each unique external link
        On Error Resume Next
        Set r = wksht.Cells.SpecialCells(xlCellTypeAllValidation)
        If Err.Number <> 0 Then
            Err.Clear
        Else
            For Each cell In r.Cells
                On Error Resume Next
                fml = cell.Validation.Formula1
                If Err.Number <> 0 Then
                    Err.Clear
                ElseIf InStr(fml, "[") <> 0 Then
                    On Error GoTo 0
                    'add to dictionary, updating existing range if identical external link was already found
                    key = fml
                    If dataValExtLinkRanges.Exists(key) Then
                        Set dataValExtLinkRanges.Item(key) = Application.Union(dataValExtLinkRanges(key), cell)
                    Else
                        Set dataValExtLinkRanges.Item(key) = cell
                    End If
                End If
            Next cell
        End If
        On Error GoTo 0

        Dim contiguousAddresses() As String
        Dim i As Long
        Dim place As String

        'report the data validation ranges we found that contain external links
        For Each key In dataValExtLinkRanges.Keys()
            contiguousAddresses = VBA.Split(dataValExtLinkRanges(key).Address, ",") 'split non-contiguous ranges into separate entries
            For i = 0 To UBound(contiguousAddresses)
                numLinks = numLinks + 1
                If Range(contiguousAddresses(i)).CountLarge > 1 Then 'this is just to pluralize "Cells" if there's more than one
                    place = "Cells " & VBA.Replace(contiguousAddresses(i), "$", "")
                Else
                    place = "Cell " & VBA.Replace(contiguousAddresses(i), "$", "")
                End If
                OutputLinkInfo "Data Validation", _
                               wkbk.FullName, _
                               wksht.Name, _
                               place, _
                               contiguousAddresses(i), _
                               VBA.CStr(key), _
                               "Select the cell and open the data validation window (Data > Data Validation). " & _
                               "Remove the external reference from the data validation formula."
            Next i
        Next key
        Set dataValExtLinkRanges = Nothing 'clear the dictionary object

' CONTINUE TO NEXT WORKSHEET
' ==========================
    Next wksht


'`````````````````````````````````````````
'WORKBOOK-LEVEL CHECKS are performed below
',,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,

    'reset error handler
    On Error GoTo 0

' Search for external links in named ranges
' =========================================
    'NOTE: This section should be improved by also searching for places where each named range is used
    'in the workbook. It could then delete any named ranges that are unused and leave those that are
    'used, providing the user with more detail about where they're used and how to manually clean them up.
    'For now, it just deletes any ranges with a broken #REF! in the external link or where the external
    'link can't be resolved to a file that actually exists.
    Dim fso As Object
    Dim startPos As Long
    Dim endPos As Long
    Dim pathPos As Long
    Dim delCt As Long
    delCt = 0
    Set fso = CreateObject("Scripting.FileSystemObject")
    If wkbk.Names.Count > 0 Then
        For nameCnt = wkbk.Names.Count To 1 Step -1
            If InStr(wkbk.Names(nameCnt).RefersTo, "[") <> 0 Then
                If InStr(wkbk.Names(nameCnt).RefersTo, "#REF!") <> 0 Then 'if it's a broken reference, just delete it
                    wkbk.Names(nameCnt).Delete
                    delCt = delCt + 1
                Else
                    'check the actual filepath to see if it can be resolved.
                    startPos = VBA.InStr(1, wkbk.Names(nameCnt).RefersTo, "='") '+ 2
                    endPos = VBA.InStr(startPos, wkbk.Names(nameCnt).RefersTo, "]") '- 1
                    pathPos = VBA.InStr(1, wkbk.Names(nameCnt).RefersTo, "\") 'verify that this is a filepath (includes filepath folder delimiter)
                    If startPos > 0 And endPos > 0 And pathPos > 0 And fso.FileExists(VBA.Replace(VBA.Mid(wkbk.Names(nameCnt).RefersTo, startPos + 2, endPos - startPos - 2), "[", "")) = False Then
                        'this is a filepath to a file that does not exist - delete it
                        wkbk.Names(nameCnt).Delete
                        delCt = delCt + 1
                    Else 'external reference does exist - reveal it in Name Manager and tell the user to manually clean it up
                        wkbk.Names(nameCnt).Visible = True
                        numLinks = numLinks + 1
                        OutputLinkInfo "Named Range", _
                                       wkbk.FullName, _
                                       "N/A", _
                                       wkbk.Names(nameCnt).Name, _
                                       "", _
                                       wkbk.Names(nameCnt).RefersTo, _
                                       "Open the name manager (Formulas > Name Manager). This named range has been unhidden and you can now delete it manually."
                    End If
                End If
            End If
        Next nameCnt
    End If

    Set fso = Nothing

    'report all automatically deleted named ranges as a single entry
    If delCt > 0 Then
        numLinks = numLinks + 1
        OutputLinkInfo "Named Range", _
                       wkbk.FullName, _
                       "N/A", _
                       "(" & delCt & " named ranges)", _
                       "", _
                       "Unrecorded", _
                       "These named ranges included unresolvable external link references and were automatically removed by the utility. " & _
                       "Save the " & Dir(wkbk.FullName) & " workbook to preserve the changes."
    End If

' Broadcast message that the utility is finished
' ==============================================
    If numLinks <= 0 Then
        MsgBox ("The utility is finished." & vbNewLine & vbNewLine & "No external links were found in " & Dir(wkbk.FullName))
    Else
        If delCt > 0 Then
            MsgBox ("The utility is finished. " & vbNewLine & vbNewLine & (numLinks - 1) & " external links were found that require manual cleanup." _
                    & vbNewLine & delCt & " external links were automatically cleaned up by the utility.")
        Else
            MsgBox ("The utility is finished." & vbNewLine & vbNewLine & numLinks & " external links were found that require manual cleanup.")
        End If
    End If

End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,129,774
Messages
5,638,264
Members
417,019
Latest member
PKDP

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top