从锯齿状数组中提取子数组并用作一维数组

Question

我正在尝试减少宏中的冗余，但我正在努力从锯齿状数组中获取一个元素并在其他地方使用它。 前提是单个工作簿，其中许多工作表按工作表名称组拆分为新文档，然后我可以将这些文档发送给流程所有者，以便他们只获取自己的数据。

以前我选择明确列出的工作表名称并粘贴到明确命名的新文档中，但我必须运行 10 个几乎相同的单独宏才能做到这一点，而且我听说在许多情况下 select 也是一个糟糕的选择.

以下是我最近的尝试，第一个问题是在 printOut 行我得到一个类型不匹配。

Sub CopyOut()
Dim printOut, groupNames, Group1, groupArray() As Variant
Dim n, j As Long
Dim reNamed, fileName As String
Dim ws As Worksheet
Dim wb1, wb2 As Workbook
groupNames = Array("Group 1", "Group 2", "Group 3", "Group 4") 'other arrays left off for length
Group1 = Array("FA_1A Report", "FA_1A", "FA_2ACS Report", "FA_2ACS", "FA_2BCS Report", "FA_2BCS", "FANUCMED Report", "FANUCMED", "FA_RRTP1 Report", "FA_RRPT1")
groupArray = Array(groupNames, Group1)

For n = 1 To UBound(groupArray)
    fileName = "CS Data Sheet" & " " & Format(Date, "mmmyy") & "-" & groupArray(n - n)(n - 1) & ".xlsm" 'concat file name string. this is not just tacked on the end of reName because i use it on it's own later
    reNamed = "C:\Users\xx\Desktop\" & fileName 'concat save location string
    Set wb1 = ThisWorkbook
    Set wb2 = Workbooks.Add 'create a new workbook, wb2
    wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled  'save with that name and location
    printOut = Join(Application.Index(groupArray, n, 0), ",")
    wb1.Sheets(printOut).Copy Before:=Workbooks(fileName).Sheets(1) 'copy the sheets for the group and paste into the newly created document
Next
End Sub

如果我完全取消 printOut 并输入一个特定的工作表名称，它只适用于那个工作表（当然），但我需要将多个工作表复制到每个新文档。

我也试过了：

For n = 1 To UBound(groupArray)
...
for j= LBound(groupArray(n)) To UBound(groupArray(n))
wb1.Sheets(groupArray(n)(j)).Copy Before:=Workbooks(fileName).Sheets(1)
next
next

遍历子数组并一次复制一张纸，但它给出的下标超出范围。在这个版本中，我尝试了各种方法将 groupArray(n)(j) 值转换为字符串或“工作表”类型以设置为变量并使用 sheet().copy 中的变量，但无济于事。

知道我哪里可能出错了吗？ 非常感谢

编辑： 我通过将上面的代码包装在 split 中（当它只是一个字符串时试图将 printOut 用作数组）并修复 Index 的参数如下，但是生成的代码仍然需要工作，因为如果缺少一张表它不会运行。

printOut = Split(Join(Application.Index(groupArray(n), 1, 0), ","), ",")

Answer 1

根据我的经验，如果您发现自己在代码中直接对工作表名称、组名称和其他数据等值进行硬编码，则往往会变得难以维护。添加更多组，或重新洗牌每组中的工作表变得有问题。我的建议是创建一个（可能是隐藏的）工作表，将您的工作表名称映射到组中。然后你有一小部分代码可以直接对其进行操作。

我的示例数据是这样设置的：

接下来，在它自己的代码模块中，我创建了一些方法来直接处理这个组地图数据。这里的主要思想是将组图数据移动到memory-based array。虽然通常我很少使用模块级全局变量，但我在此示例中使用了一个来说明如何处理数据，方法是每次执行宏时只将数据读入数组一次。

（这些是 Subs 和 Functions。对于我自己的代码，我可能会创建一个 VBA 类来以面向对象的方式处理数据。）

所以有一个Private Sub来获取数据：

Option Explicit

Private groupData As Variant

Private Sub GetGroupData()
    Const GROUP_WS_NAME As String = "GroupMap"
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)

    Dim lastRow As Long
    Dim lastCol As Long
    With ws
        '--- how many columns of groups?
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
        groupData = .Range("A1").Resize(lastRow, lastCol).Value
    End With
End Sub

现在很容易弄清楚有多少组：

Public Function NumberOfGroups() As Long
    If IsEmpty(groupData) Then GetGroupData
    NumberOfGroups = UBound(groupData, 2)
End Function

以及特定组中有多少项：

Public Function NumberInGroup(ByVal groupNumber As Long)
    If IsEmpty(groupData) Then GetGroupData
    '--- count the number of array values that have data
    Dim i As Long
    For i = LBound(groupData, 1) To UBound(groupData, 1)
        If groupData(i, groupNumber) = vbNullString Then
            '--- we found the first empty cell in this array, we're done
            Exit For
        Else
            NumberInGroup = NumberInGroup + 1
        End If
    Next i
    '--- subtract one to discount the header value
    NumberInGroup = NumberInGroup - 1
End Function

最简单的方法是获取任何组的值：

Public Function GetGroupValue(ByVal groupNumber As Long, _
                              ByVal groupIndex As Long) As Variant
    If IsEmpty(groupData) Then GetGroupData
    '--- always add one to the index to account for the header value
    GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function

注意在每个方法的开头检查If IsEmpty(groupData) Then GetGroupData。这样可以确保在必要时始终加载 groupData 数组。

此示例对其进行了快速测试（在不同的代码模块中）：

Option Explicit

Sub test()
    Dim totalGroups As Long
    totalGroups = NumberOfGroups()

    Dim i As Long
    Dim j As Long
    For i = 1 To totalGroups
        Dim totalInGroup As Long
        totalInGroup = NumberInGroup(i)
        For j = 1 To totalInGroup
            Debug.Print "group " & i & " = " & GetGroupValue(i, j)
        Next j
    Next i
End Sub

这里是单个块中的整个组数据代码模块：

Option Explicit

Private groupData As Variant

Private Sub GetGroupData()
    Const GROUP_WS_NAME As String = "GroupMap"
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)

    Dim lastRow As Long
    Dim lastCol As Long
    With ws
        '--- how many columns of groups?
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
        groupData = .Range("A1").Resize(lastRow, lastCol).Value
    End With
End Sub

Public Function NumberOfGroups() As Long
    If IsEmpty(groupData) Then GetGroupData
    NumberOfGroups = UBound(groupData, 2)
End Function

Public Function NumberInGroup(ByVal groupNumber As Long)
    If IsEmpty(groupData) Then GetGroupData
    '--- count the number of array values that have data
    Dim i As Long
    For i = LBound(groupData, 1) To UBound(groupData, 1)
        If groupData(i, groupNumber) = vbNullString Then
            '--- we found the first empty cell in this array, we're done
            Exit For
        Else
            NumberInGroup = NumberInGroup + 1
        End If
    Next i
    '--- subtract one to discount the header value
    NumberInGroup = NumberInGroup - 1
End Function

Public Function GetGroupValue(ByVal groupNumber As Long, ByVal groupIndex As Long) As Variant
    If IsEmpty(groupData) Then GetGroupData
    '--- always add one to the index to account for the header value
    GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function

Answer 2

如果我猜对了，您有一个包含 n 个工作表的主工作簿，并且您想要将其中的一些分组，然后为每个组创建一个新工作簿并粘贴到其分配的工作表中。

我认为在主工作簿中保留“配置”文件以设置组和工作表的方法比编辑到代码中更合适。示例：

以下代码将使用 A 列中的名称创建一个文件，并复制在其各自行上定义的所有工作表。

Option Explicit

Sub CopyOut()
    Dim groupArr() As Variant
    Dim wb2 As Workbook
    Dim lastRow As Long, lastCol As Long, highestNumOfSheets As Long, i As Long, j As Long, arrColumns As Long
    Dim reNamed As String, fileName As String, configSheet As String
    Dim removedSheet1 As Boolean

    ' Modify the sheet name here
    configSheet = "config"

    ' Build an array from sheet defined groups
    With ThisWorkbook.Worksheets(configSheet)
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = 2 To lastRow
            lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
            If lastCol > highestNumOfSheets Then highestNumOfSheets = lastCol
        Next i

        groupArr = .Range(.Cells(2, 1), .Cells(lastRow, highestNumOfSheets)).Value2
    End With

    Application.ScreenUpdating = False

    For i = LBound(groupArr) To UBound(groupArr)
        fileName = "CS Data Sheet " & Format(Date, "mmmyy") & "-" & groupArr(i, 1) & ".xlsm"
        reNamed = Environ("UserProfile") & "\Desktop\" & fileName

        removedSheet1 = False   ' Reset this on each new workbook created
        Set wb2 = Workbooks.Add

        ' Pick all the sheet names for the current group
        For j = 2 To UBound(groupArr, 2)

            ' Skip empty values from array (if it's the case) and skip missing sheets
            If Trim(groupArr(i, j)) <> vbNullString And SheetExists(groupArr(i, j)) Then
                ThisWorkbook.Worksheets(groupArr(i, j)).Copy Before:=wb2.Worksheets(1)

                ' Remove Sheet1 from the new Workbook
                If removedSheet1 = False Then
                    With Application
                        .DisplayAlerts = False
                        wb2.Worksheets("Sheet1").Delete
                        removedSheet1 = True
                        .DisplayAlerts = True
                    End With
                End If
            End If
        Next j

        ' Here you might need an error handler if you think you're going to run the macro multiple times in the same day
        ' If the file exists already this will throw an error
        ' A quick lazy way is to add time (including seconds) when you define the file name above

        wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled
        wb2.Close
        If Not wb2 Is Nothing Then Set wb2 = Nothing
    Next i

    Application.ScreenUpdating = True
End Sub

Function SheetExists(ByVal sheetName As String) As Boolean
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo 0

    If Not ws Is Nothing Then
        SheetExists = True
        Set ws = Nothing
    End If
End Function

当然，它可以通过错误处理和其他检查（取决于您想要完全实现的目标）进行调整，但它应该为您提供代码的另一种视图。

编辑：添加了检查工作表是否存在的功能。