我正在使用vba从父工作簿创建新的工作簿。新创建的工作簿与其父级工作簿存在外部链接。我尝试断开与父级工作簿的链接，结果如下：
如何使用VBA不仅断开链接，还要删除所有有关外部链接的信息？3个回答
24
我不得不修复一些文件，这些文件中有几十个外部链接，分散在单元格、条件格式、数据验证、图表、命名范围等处。在 Excel 的“编辑链接”窗口或使用 VBA .BreakLink 方法时，无法断开外部链接。
我创建了这个宏，可以很好地查找工作簿任何地方的外部链接。它会自动清理一些链接，并提供详细的说明来清理其他链接（包括外部链接存在的确切位置）。
'
' *********************************************************************
' 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://dev59.com/w1YM5IYBdhLWcg3wzSkg
' *********************************************************************
'
' 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
示例输出：
- jramm
6
6
链接可能隐藏在多个地方，包括条件格式、数据验证和外部来源。但是，如果你的链接只是指向其他地方的基本公式，则以下方法可以清除它们：
With ActiveWorkbook
For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
.BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks
Next
End With
- CLR
0
我尝试了所有这些解决方案，还有其他十几个方法，但都没有起作用。
最终我在Open Office中打开了该文件，它能够删除链接，因此我将文件导出为Excel格式。希望这次可以成功...
- DrWhat
网页内容由stack overflow 提供, 点击上面的可以查看英文原文，
原文链接
原文链接
With g_ResultBook.Worksheets("Sheet1")的出现替换为With g_ResultBook.Worksheets.Item(1)。例如，在德语环境中，“Sheet1”不存在，但它可能会被称为“Tabelle1”。 - Andreas Covidiot.Item(1)表示法。感谢您指出这一点。 - jrammstartPos = VBA.InStr(1, wkbk.names(nameCnt).RefersTo, "='")更改为startPos = VBA.InStr(1, wkbk.names(nameCnt).RefersTo, "='"),If startPos > 0 Then,endPos = VBA.InStr(startPos, wkbk.names(nameCnt).RefersTo, "]"),End If。我会尝试在以后的时间进行测试和更新。 - jramm