根据单元格值中的选项卡名称，跨多个选项卡循环到新工作簿功能的副本

Question

我想从电子表格中的每个选项卡复制数据，并将其另存为新工作簿。 原始工作簿具有许多选项卡（大约50个），并且其中一个选项卡设置为宏可以从中运行数据，因为将来可能会添加新的选项卡。 宏数据选项卡包含每个新工作簿的文件位置，选项卡的名称以及其他宏将这些新创建的工作簿通过电子邮件发送给相关方的一些信息。

问题在于使宏识别选项卡名称以查找要复制的范围，因为选项卡名称在单元格中列出。 我不确定是否可以使用此列表，或者不确定是否在末尾添加一张工作表以循环从指定的开始位置到所有带有if的工作表。

Sub Datacopy()

    Dim ws As Worksheet

    With Application
        .ScreenUpdating = False
    End With

    Application.DisplayAlerts = False

    Set ws = Sheets("email")

    For Each Cell In ws.Columns("B").Cells

        Dim file1 As String

        file1 = Cell.Offset(0, 3).Text

            Sheets("cell.value").Range("A1:L500").Copy
            Workbooks.Add.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme)
            Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteComments)
            ActiveWorkbook.SaveAs Filename:=file1
            ActiveWorkbook.Close

    Next Cell

    Application.DisplayAlerts = True

    With Application
        .ScreenUpdating = True
    End With

    MsgBox ("Finished making files!")

End Sub

Answer 1

这样的事情应该为您工作。 请注意以下几点：

• 代码假定工作表“电子邮件”上有一个标题行，即第1行，实际数据从第2行开始。
• 它检查B列单元格在工作簿中是否为有效的工作表名称。

我已验证此代码可以正常工作，并且根据您的原始帖子可以正常使用：

Sub Datacopy()

    Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsTemp As Worksheet
    Dim rSheetNames As Range
    Dim rSheet As Range

    Set wb = ActiveWorkbook
    Set wsData = wb.Sheets("email")

    Set rSheetNames = wsData.Range("B2", wsData.Cells(Rows.Count, "B").End(xlUp))
    If rSheetNames.Row < 2 Then Exit Sub    'No data

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    For Each rSheet In rSheetNames
        If Not Evaluate("ISERROR('" & rSheet.Text & "'!A1)") Then
            Set wsTemp = Sheets.Add
            Sheets(rSheet.Text).Range("A1:L500").Copy
            wsTemp.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
            wsTemp.Range("A1").PasteSpecial xlPasteComments
            wsTemp.Move
            ActiveWorkbook.SaveAs rSheet.Offset(, 3).Text
            ActiveWorkbook.Close False
        End If
    Next rSheet

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    MsgBox "Finished making files!"

End Sub