vba 如何从链接到另一个工作簿的工作簿中删除链接

How do I remove links from a workbook linked to another

提问by Mike Barnes

I have a sheet(Questions) in a workbook(Rating) that has a button at the bottom of the Questions sheet that copies sheet 2(quote) from the Rating workbook and pastes it in a new workbook that is named according to the quote number and then saved.

我在工作簿（评级）中有一个工作表（问题），在问题工作表底部有一个按钮，可以从评级工作簿中复制工作表 2（报价）并将其粘贴到根据报价编号命名的新工作簿中然后保存。

Here is that code:

这是代码：

Sub GetQuote()
    Range("AK548").Select
    Selection.Copy
    Range("AK549").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Dim Output As Workbook
    Dim FileName As String

    Set Output = Workbooks.Add
    FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("AK545").Value & ".xls"
    Output.SaveAs FileName

    Application.DisplayAlerts = False

    Output.Worksheets("Sheet1").Delete
    ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
    Output.Worksheets(1).Name = "Sheet1"

    Application.DisplayAlerts = True
    Output.Protect Password:="12345"
    Output.Save
End Sub

Now I intend on removing the links that now exsist between this new copy and the Quote sheet and only leave the values. How would I do this?

现在我打算删除这个新副本和报价单之间现在存在的链接，只保留值。我该怎么做？

I have found this code that should delete the links that exsist:

我发现这段代码应该删除存在的链接：

Dim Cell As Range, FirstAddress As String, Temp As String
    'delete all links from selected cells
    Application.ScreenUpdating = False
    With Selection
        Set Cell = .Find("=*!", LookIn:=xlFormulas, searchorder:=xlByRows, _
        LookAt:=xlPart, MatchCase:=True)
        On Error GoTo Finish
        FirstAddress = Cell.Address
        Do
            Temp = Cell
            Cell.ClearContents
            Cell = Temp
            Set Cell = .FindNext(Cell)
        Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
    End With
Finish:

All I have done extra is put this code in below the code that Names and copies the sheet and that did not work?

我所做的所有额外工作就是将此代码放在命名并复制工作表的代码下方，但它不起作用？

So now how would I combine these two pieces of code so that everything gets copied and the links removed?

那么现在我将如何组合这两段代码，以便复制所有内容并删除链接？

回答by Tristan

I had existing workbooks that had external links that i needed to remove from the workbooks and then re save them.

我有现有的工作簿，其中包含需要从工作簿中删除然后重新保存的外部链接。

This worked for me:

这对我有用：

Sub BreakExternalLinks()
'PURPOSE: Breaks all external links that would show up in Excel's "Edit Links" Dialog Box
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault

Dim ExternalLinksArray As Variant
Dim wb As Workbook
Dim x As Long

Set wb = ActiveWorkbook

'Create an Array of all External Links stored in Workbook
  ExternalLinksArray = wb.LinkSources(Type:=xlLinkTypeExcelLinks)

'if the array is not empty the loop Through each External Link in ActiveWorkbook and Break it
 If IsEmpty(ExternalLinksArray) = False then
     For x = 1 To UBound(ExternalLinksArray )
        wb.BreakLink Name:=ExternalLinksArray (x), Type:=xlLinkTypeExcelLinks
      Next x
end if

End Sub

回答by Maus

This piece of code kills all connections in the active workbook... apologies, but can't remember where I got it.

这段代码杀死了活动工作簿中的所有连接......抱歉，但不记得我从哪里得到的。

    'Kill Connections
    If ActiveWorkbook.Connections.Count > 0 Then
        For i = 1 To ActiveWorkbook.Connections.Count
        ActiveWorkbook.Connections.Item(1).Delete
        Next i
    Else
    End If

Tested with your code, this seems to work:

用你的代码测试，这似乎有效：

    Dim Output As Workbook
Dim FileName As String

Set Output = Workbooks.Add
FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("A1").Value & ".xls"
Output.SaveAs FileName

Application.DisplayAlerts = False

Output.Worksheets("Sheet1").Delete
ThisWorkbook.Worksheets(2).Copy Before:=Output.Worksheets("Sheet2")
Output.Worksheets(1).Name = "Sheet1"

Output.Worksheets(1).Select
If ActiveWorkbook.Connections.Count > 0 Then
    For i = 1 To ActiveWorkbook.Connections.Count
    ActiveWorkbook.Connections.Item(1).Delete
    Next i
Else
End If

Application.DisplayAlerts = True
Output.Protect Password:="12345"
Output.Save

回答by MiVoth

Perhaps it would help, if you don't use the actual copy & paste functions. If you only need the values of the cells, then change your macro to

如果您不使用实际的复制和粘贴功能，也许会有所帮助。如果您只需要单元格的值，则将宏更改为

Sub GetQuote()
    Range("AK548").Select
    Selection.Copy
    Range("AK549").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Dim Output As Workbook
    Dim FileName As String

    Set Output = Workbooks.Add
    FileName = ThisWorkbook.Path & "\" & ThisWorkbook.Worksheets("Questions").Range("AK545").Value & ".xls"
    Output.SaveAs FileName

    Application.DisplayAlerts = False
    Dim v, r As Long, c As Long
    With ThisWorkbook.Worksheets(2)
        r = .Cells.SpecialCells(xlCellTypeLastCell).Row
        c = .Cells.SpecialCells(xlCellTypeLastCell).Column
        v = .Range(.Cells(1, 1), .Cells(r, c))
    End With
    With Output.Worksheets(1)
        .Range(.Cells(1, 1), .Cells(r, c)) = v
    End With

    Application.DisplayAlerts = True
    Output.Protect Password:="12345"
    Output.Save
End Sub

This copies the values of your origin sheet to the new workbook sheet, without any links.

这会将原始工作表的值复制到新的工作簿工作表，而没有任何链接。

P.S.: Don't mix up ThisWorkbookand ActiveWorkbook. ThisWorkbookis the workbook where the macro is located (, but not necessarily the active workbook). ActiveWorkbookis the workbook, you see at that time.

PS：不要混淆ThisWorkbook和ActiveWorkbook。ThisWorkbook是宏所在的工作簿（但不一定是活动工作簿）。ActiveWorkbook是工作簿，你当时看到的。