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

Question

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

问题是让宏识别标签名称以查找要复制的范围，因为标签名称列在一个单元格中。我不确定是否可以使用这个列表，或者我是否在末尾添加一个 sheet 以从指定的开始位置循环遍历所有 sheets 直到那个带有 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

像这样的东西应该适合你。请注意以下几点：

代码假定在 sheet "email" 上它有一个 header 行，即第 1 行，实际数据从第 2 行开始。
检查 B 列单元格是否是工作簿中的有效作品sheet名称

我已根据您的原始 post:

验证此代码可以正常工作并且符合预期

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

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

Looping a copy to new workbook function across multiple tabs based on tab names in cell values

excel

tabs

vba