将基础数据表连同选定的工作表从源工作簿复制到新工作簿

Question

我正在考虑构建一个主工作簿，该工作簿每月接收所有成本中心的数据转储，然后将在工作簿中填充大量工作表，然后需要将其拆分并发送给服务负责人。服务负责人将收到基于工作表名称的前 4 个字符选择的工作表（尽管这可能会在适当的时候改变）。

例如 1234x、1234y、5678a、5678b 将生成两个名为 1234 和 5678 的新工作簿，每个工作簿有两张。

我从各个论坛拼凑了一些代码来创建一个宏，该宏将通过定义服务头 4 个字符代码的硬编码数组工作并创建一系列新工作簿。这似乎有效。

但是.. 我还需要在源文件（称为“数据”）中包含主数据转储表以及要复制的文件数组，以便链接保留在复制的数据表中。如果我写一行单独复制数据表，新工作簿仍然引用源文件，服务负责人无权访问。

所以主要问题是：如何将“数据”选项卡添加到 Sheets(CopyNames) 中。复制代码以便与数组中的所有其他文件同时复制以保持链接完整？

第二个问题是如果我决定它是工作表的前两个字符定义与服务负责人相关的工作表，我如何调整代码的拆分/中间行 - 我已经尝试过，但我被捆绑了以节为单位！

非常感谢任何其他使代码更优雅的提示（可能有很长的服务头代码列表，我相信有更好的方法来创建一个循环的例程列表）

    Sub Copy_Sheets()
  Dim strNames As String, strWSName As String
  Dim arrNames, CopyNames
  Dim wbAct As Workbook
  Dim i As Long
  Dim arrlist As Object

  Set arrlist = CreateObject("system.collections.arraylist")
  arrlist.Add "1234"
  arrlist.Add "5678"


  Set wbAct = ActiveWorkbook
  For Each Item In arrlist

  For i = 1 To Sheets.Count
    strNames = strNames & "," & Sheets(i).Name
  Next i
    arrNames = Split(Mid(strNames, 2), ",")

    'strWSName =("1234")
    strWSName = Item

        Application.ScreenUpdating = False
        CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
        If UBound(CopyNames) > -1 Then
          Sheets(CopyNames).Copy
          ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
          ActiveWorkbook.Close
          wbAct.Activate
        Else
          MsgBox "No sheets found: " & strWSName
        End If

    Next Item

        Application.ScreenUpdating = True

End Sub

Answer 1

Option Explicit

Sub CopySheets()

With ThisWorkbook

    Dim SheetIndex As Long
    Dim ValidSheetNames() As String
    ReDim ValidSheetNames(1 To .Worksheets.Count)

    ' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
    Dim ws As Worksheet
    For Each ws In .Worksheets
        If ws.Name <> "DEDICATEDSHEET" Then
            SheetIndex = SheetIndex + 1
            ValidSheetNames(SheetIndex) = ws.Name
        End If
    Next ws
    ReDim Preserve ValidSheetNames(1 To SheetIndex)

    ' Read all ServiceCodes into a 1-dimensional array '
    Dim ServiceHeadCodes As Variant
    ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)

    Dim CodeIndex As Long

    ' Now loop through each ServiceHeadCode '
    For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)

        ' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
        Dim SheetsToCopy() As String
        SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)

        ' Check if SheetToCopy now contains any sheet names at all. '
        If UBound(SheetsToCopy) > -1 Then

            ' Add the name of the Data sheet to the end of the array '
            ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
            SheetsToCopy(UBound(SheetsToCopy)) = "Data"


            Dim OutputWorkbook As Workbook
            Set OutputWorkbook = Application.Workbooks.Add

            ' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
            .Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)

            ' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
            ' But suppress the Are you sure you want to delete this sheet.. message. '
            Application.DisplayAlerts = False
            OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
            Application.DisplayAlerts = True
            ' Re-enable alerts, as we want to see any other dialogue boxes/messages

            ' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
            OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
            OutputWorkbook.Close
        Else
            MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
        End If

    Next CodeIndex

End With

End Sub

未经测试并在移动设备上编写，格式错误，敬请见谅。

此方法建议您将所有服务负责人代码存储在通过 Excel 表格命名法引用的专用工作表上的 1 列 Excel 表格中（这可能比 ArrayList.Add 为每个新的服务负责人代码更容易）。

我假设代码存储在主工作簿（'thisworkbook'）中，这可能不是真的。

如果您稍后决定 SheetsToCopy 将由前 2、3 或 X 个字符确定，您可以直接在电子表格本身上修改 serviceheadcodes 表，或者您可以使用 left$() 函数修改数组本身。

希望它有效或给你一些想法。

编辑：这是我的工作表和表格布局（我认为与您的相匹配）。

这就是上面的代码在我的电脑上给我的。