Копирование Рабочие листы обрывать ссылки

Question

У меня есть два подсайта в VBA, которые выполняют 2 разные, но похожие задачи. Один позволяет вам выбирать листы из рабочей книги с помощью всплывающего окна, а затем копировать эти листы в новую рабочую книгу. Другой позволяет вручную заполнить список имен листов, которые вы хотите скопировать (то есть настроить «сортировку») на листе, а затем скопировать все листы в новую пустую рабочую книгу аналогично первой ,

Проблема, с которой я столкнулся, - с первым суб, я могу сломать ссылки после копирования в новую Рабочую книгу, но со вторым я не могу сломать ссылки. Я думаю, что это связано с несколькими определенными именами в исходной книге, как если бы вы «переместили или скопировали/создали копию» вручную, вы можете сломать ссылки.

Есть ли какой-нибудь код, который я могу добавить к приведенному ниже (на оба подкаталога, если это возможно), который автоматически сломает все ссылки в новой книге на старый? Или, по крайней мере, возможно ли изменить вторую часть так, чтобы она копировалась попеременно так же, как первая, которая затем позволит мне разбить ссылки вручную?

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, так что неработающие ссылки поддерживаются.