Copy Worksheets Break Links

Question

Ich habe die folgenden 2 Subs in VBA, die 2 verschiedene, aber ähnliche Aufgaben durchführen. Mit einem können Sie Blätter aus einer Arbeitsmappe mithilfe eines Kontrollkästchens auswählen und diese Blätter dann in ein neues leeres Arbeitsbuch kopieren. Mit der anderen Option können Sie manuell eine Liste der Namen der Blätter, die Sie kopieren möchten (z. B. ein "Stapel") auf einem Blatt auffüllen und dann alle Blätter in ein neues leeres Arbeitsbuch auf ähnliche Weise wie das erste kopieren .

Das Problem, das ich habe, ist - mit dem ersten Sub bin ich in der Lage, Links nach dem Kopieren in das neue Arbeitsbuch zu brechen, aber mit dem zweiten Sub bin ich nicht in der Lage, Links zu brechen. Ich denke, es hat mit einer Reihe von definierten Namen innerhalb der ursprünglichen Arbeitsmappe zu tun, als ob Sie manuell "Verschieben oder Kopieren/Erstellen einer Kopie", Sie in der Lage sind, die Links zu brechen.

Gibt es einen Code, den ich dem unten hinzufügen kann (auf beide Subs, wenn möglich), der automatisch alle Verbindungen in dem neuen Arbeitsbuch zu dem alten bricht? Oder ist es zumindest möglich, das zweite Sub so zu modifizieren, dass es in ähnlicher Weise wie das erste kopiert wird, was mir dann erlaubt, Links manuell zu brechen?

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

versuchen, etwas wie folgt aus:

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 

Dank

Answer 2

Dies ist nicht getestet, aber ich denke, wenn man in einem Unterprogramm zu Ihrer Quelle Arbeitsmappe VBA-Code wie folgt hinzu:

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 

Und dann nennen Sie es, nachdem Sie die Blätter auf die neue kopieren Arbeitsmappe

Call BreakLinks(newBook) 

Das sollte den gewünschten Effekt des Trennens dieser Links erreichen. Seien Sie einfach sicher, dass die Links zu einer beliebigen Art von Save oder SaveAs Operation gebrochen sind, so dass die unterbrochenen Links beibehalten werden.