Question

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

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

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

但是..我还需要在源文件中包含主数据转储表（称为＆＃34;数据＆＃34;），并复制文件数组，以便链接保留在数据表中复制过来。如果我写一行来分别复制数据表，新工作簿仍会返回源文件，哪些服务负责人无权访问。

所以主要的问题是：如何添加＆＃34;数据＆＃34;选项卡进入表格（CopyNames）。复制代码，以便它与数组中的所有其他文件一起复制，以保持链接完好无损？

第二个问题是，如果我确定工作表的前两个字符定义了与服务头相关的表单，我该如何调整分割/中间代码行 - 我已经试过但是我正在试用捆绑在一起！

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

title

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

未经测试并写在手机上，抱歉格式不正确。

此方法建议您将所有服务主管代码存储在专用工作表中的1列Excel表中，该工作表通过Excel表命名法引用（对于每个新的服务主管代码，这可能比ArrayList.Add更容易）。 / p>

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

如果您稍后决定SheetsToCopy将由前2,3或X字符决定，您可以直接在电子表格上修改serviceheadcodes表 - 或者您可以使用左$（）函数修改数组本身。

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

编辑：这是我的工作表和表格布局（我假设与您的相符）。

这就是上面的代码在我的计算机上给我的。

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

1 个答案: