Copia fogli di lavoro interrompono i collegamenti

Ho il sottostante 2 in VBA che esegue 2 compiti diversi ma simili. Uno consente di select i fogli da una cartella di lavoro utilizzando una window di dialogo della casella di controllo e quindi copiare questi fogli in una nuova cartella di lavoro vuota. L'altro consente di popolare manualmente un elenco di nomi dei fogli che si desidera copiare (ad esempio, impostare un "batch" di tipi) su un foglio e quindi copiare tutti i fogli in una nuova cartella vuota in modo simile al primo .

Il problema che sto avendo è – con il primo sotto in grado di interrompere i collegamenti dopo la copia nella nuova cartella di lavoro, ma con il secondo sottoposto non sono in grado di interrompere i collegamenti. Penso che abbia a che fare con un certo numero di nomi definiti all'interno della cartella di lavoro originale, come se "Sposta o copia / crea una copia" manualmente, è in grado di rompere i collegamenti.

C'è qualche codice che posso aggiungere al di sotto (su entrambi i subs se ansible) che romperà automaticamente tutti i collegamenti nella nuova cartella di lavoro al vecchio? O alless, è ansible modificare il secondo sotto in modo che copia in modo simile alla prima che mi permetterà di rompere manualmente i collegamenti?

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 

Prova qualcosa di simile:

 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 arrays 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 

Grazie

Questo non è testato, ma penso che se si aggiunge una sottoprogramma alla tua cartella di lavoro di origine VBA come questo:

 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 

Quindi chiamarlo dopo aver copiato i fogli nella nuova cartella di lavoro

 Call BreakLinks(newBook) 

Questo dovrebbe get l'effetto desiderato di interrompere tali legami. Basta essere sicuri che i collegamenti siano interrotti a qualsiasi tipo di operazione di Save o Save modo che i collegamenti interrotti vengano mantenuti.