Excel 中工作表的条件导入

Question

我有大量项目需要以不同的形式申请。我的表格摘录如下：

    1   2   3   4   5   6   7   8   9   10  11  12  13  14
A   -   -   C   -   -   -   -   -   C   -   -   -   -   -
B   -   -   -   -   C   -   C   -   -   -   -   -   -   C

这意味着对于项目 AI 必须附上表格 3 和 9；对于项目 B 则必须附上表格 5、7 和 14。

是否可以生成一个以项目标题包含相关表格作为工作表的工作簿。

（表格本身是简单的 Excel 表，可以根据需要重命名/操作）

任何帮助都将不胜感激，因为有数百个项目和数十种表格，因此手动依次导入每个项目的工作表将非常耗时！

谢谢

Answer 1

山姆，这是解决这个有趣问题的一个起点。

我设置了一个与您的类似的工作表，不同之处在于我用表单名称标记了列，用新的工作表名称标记了行，如下所示：

您会注意到，包含条件的表格位于第一个选项卡上，而表单位于其他选项卡上。选项卡上的名称与表格第 1 行中的表单名称完全对应。

接下来我进入开发者模式并创建了一个新的宏。并输入代码：

Sub Macro1()
'
' Macro1 Macro
' Copy sheets into new workbooks
'
'

Dim myWB As Workbook
Set myWB = ActiveWorkbook
Dim mySheet As String
Sheets(1).Select
mySheet = ActiveSheet.Name

Dim workbookName As String
Dim formName As String
For Each onecell In Range("b2:d3")
    If onecell = "C" Then
        workbookName = Cells(onecell.Row, 1).Value
        formName = Cells(1, onecell.Column).Value
        Sheets(formName).Select
        'MsgBox "WB: " & workbookName & " Form: " & formName & " Current: " & myWB.Name & ":" & mySheet
        ActiveWorkbook.Sheets(formName).Copy After:=Workbooks(workbookName).Sheets(1)
        Windows(myWB.Name).Activate
        Sheets(mySheet).Select
        MsgBox "Form: " & formName & " copied to Workbook " & workbookName
    End If
Next

End Sub

原位宏如下所示：

此代码不会执行所有可以执行的检查，也不会包括创建新工作簿（您可以将其添加到宏中）。要使其工作，您需要创建并保存空白工作簿，其名称与表格第一列中的名称完全相同（即我的示例中的 Workbook1.xlsx 和 Workbook1.xlsx）。需要打开这些工作簿才能使代码工作。

最后按“运行”执行宏。您将看到以下内容：

每次将表单复制到工作簿时都会出现此消息。您可以通过在代码中注释掉该消息来关闭它。否则按“确定”直到复制所有表单。结果如下：

就是这样！希望这能有所帮助，如果您确实修改了代码以获得更好的解决方案，请将其发回，以便我们都能受益。

Answer 2

感谢所有帮助过的人，这是我使用的最后一个宏：

Sub One()
'
'Create and open workbooks of title col a & .xls
Dim masterWB As Workbook
Set masterWB = ActiveWorkbook
Dim aName As String

'set last row of items
For item = 2 To 13
    aName = masterWB.Sheets(1).Cells(item, 1).Value
    Workbooks.Add
    ActiveWorkbook.SaveAs fileName:=aName & ".xls"
    Sheets(1).Name = "Comments"

'put forms of title row 1 in workbook of title col a & .xls
    Dim myWB As Workbook
    Set myWB = ActiveWorkbook
    Dim mySheet As String
    Sheets(1).Select
    mySheet = ActiveSheet.Name

Next
masterWB.Sheets(1).Activate

Dim workbookName As String
Dim formName As String
'insert range of forms
For Each onecell In Range("d2:ae13")
    If onecell = "C" Or onecell = "II" Then

        masterWB.Sheets(1).Activate
        workbookName = Cells(onecell.row, 1).Value
        workbookName = workbookName & ".xls"

        formName = Cells(1, onecell.Column).Value
        Sheets(formName).Select
        'MsgBox "WB: " & workbookName & " Form: " & formName & " Current: " & myWB.Name & ":" & mySheet
        ActiveWorkbook.Sheets(formName).Copy After:=Workbooks(workbookName).Sheets(1)



        'reset
        Windows(myWB.Name).Activate
        Sheets(mySheet).Select
        'MsgBox "Form: " & formName & " copied to Workbook " & workbookName
    End If
Next

End Sub