複製工作表中斷鏈接

Question

我在VBA中執行2個不同但相似的任務下面的2個子。 One允許您使用複選框彈出框從工作簿中選擇工作表，然後將這些工作表複製到新的空白工作簿中。另一個允許您手動填充要複製的工作表名稱列表（即，在工作表中設置「批次」類別），然後將所有工作表複製到與第一個工作簿類似的新工作簿中。

我遇到的問題是 - 第一部分我能夠在複製到新的工作簿後斷開鏈接，但是第二部分我無法斷開鏈接。我認爲它與原始工作簿中的許多已定義名稱有關，就像手動「移動或複製/創建副本」一樣，您可以打破鏈接。

有沒有我可以添加到下面的任何代碼（如果可能的話，都將添加到兩個潛艇上），這將自動將新的工作簿中的所有鏈接打破爲舊的？或者至少，是否有可能修改第二個子文件，以便與第一個子文件以類似的方式進行復制，從而使我能夠手動中斷鏈接？

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

嘗試這樣：

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 

感謝

Answer 2

這不是測試，但我認爲，如果你在一個子程序添加到您的源工作簿的VBA代碼：

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 

然後調用它，你的表複製到新的後工作簿

Call BreakLinks(newBook) 

這應該達到切斷這些鏈接的預期效果。只要確保鏈接被破壞到任何種類的Save或SaveAs操作，以便保持斷開的鏈接。