根据位于另一个工作表中的列表多次复制基础工作表

Question

我想为名为Base的标签上的单个数组中包含的每个值创建一个名为List的标签的副本。

Base标签的每个副本都需要命名为List标签上包含的每个值。 C1上的单元Base需要设置为数组List中的值（也是选项卡的名称）。

该列表将包含300个值，并且将工作簿中的每个选项卡作为原始副本将奇怪地成为共享工作簿的最佳解决方案。

我想将每个工作表展平为静态值。如果我作为动态内容离开，每个工作表都有许多会导致性能问题的公式。

这是我的代码。

Sub Generator()

    Dim cell As Range
    Dim b As String
    Dim e As String
    Dim s As Integer
    Sheets("List").Select
    b = "A1"
    e = Range(b).End(xlDown).Address

    For Each cell In Range(b, e)
        s = Sheets.Count
        Sheets("Base").Copy After:=Sheets(s)
        Range("C1").Select

        ActiveCell.FormulaR1C1 = cell.Value

        Sheets(s + 1).Name = cell.Value
    Next cell
End Sub

在尝试解决方案之后，唯一的变化是我想在粘贴新工作表之后但在工作表被压平之前重新计算整个工作表（功能相当于按F9键）。我假设需要插入一行代码，如下面LetUsContinue子中所示。

    LetUsContinue:
          On Error GoTo 0 '--Turn off error handling.
           .Range("C1") = Cell.Value '--Change C1 to the name of current sheet.

  '---->>>>>recalc the sheet here

         .Cells.Copy '--Change all cells...
        .Cells.PasteSpecial xlPasteValues '--... to values.
    End With
Next Cell

Answer 1

试试这个：

Sub MoreAndMoreSheets()

    Dim ListSh As Worksheet, BaseSh As Worksheet
    Dim NewSh As Worksheet
    Dim ListOfNames As Range, LRow As Long, Cell As Range

    With ThisWorkbook
        Set ListSh = .Sheets("List") '--Qualify our sheets.
        Set BaseSh = .Sheets("Base")
    End With

    LRow = ListSh.Cells(Rows.Count, "A").End(xlUp).Row '--Get last row of list.
    Set ListOfNames = ListSh.Range("A1:A" & LRow) '--Qualify our list.

    With Application
        .ScreenUpdating = False '--Turn off flicker.
        .Calculation = xlCalculationManual '--Turn off calculations.
    End With

    For Each Cell In ListOfNames '--For every name in list...
        BaseSh.Copy After:=Sheets(Sheets.Count) '--Copy Base sheet.
        Set NewSh = ActiveSheet '--Let's name it NewSh.
        With NewSh
            On Error GoTo Boom '--In case of errors.
            .Name = Cell.Value '--Set the sheet's name to that of our current name in list.
            GoTo LetUsContinue '--Skip to the LetUsContinue block.
Boom: '--In case of duplicate names...
            .Name = "Dup" & Cell.Value '--Add "Dup" to beginning.
            .Tab.ColorIndex = 53 '--Change the tab color of the duplicate tab to orange for easy ID.
LetUsContinue:
            On Error GoTo 0 '--Turn off error handling.
            .Range("C1") = Cell.Value '--Change C1 to the name of current sheet.
            .Calculate '--Calculate page.
            .Cells.Copy '--Change all cells...
            .Cells.PasteSpecial xlPasteValues '--... to values.
        End With
    Next Cell

    With Application
        .ScreenUpdating = True '--Return to proper state.
        .Calculation = xlCalculationAutomatic '--Return to automatic calculation.
    End With

    BaseSh.Activate '--Select Base.
    MsgBox "Done!" '--Done!

End Sub

<强>截图：

<强> 设置：

运行代码后的结果：

阅读评论。希望这可以帮助。 ：）