Question

我在VBA中有以下2个潜艇执行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

这还没有经过测试，但我想如果你在你的源工作簿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操作，以便维护损坏的链接。

Answer 2

尝试这样的事情：

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

由于

复制工作表中断链接

2 个答案: