vba 根据位于另一个工作表中的列表多次复制基础工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/21033977/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy a base sheet multiple times based on a list located in another sheet
提问by user3179827
I want to create a copy of a tab named Basefor every value contained in a single array on a tab called List.
我想创建一个选项卡的副本，该选项卡以Base名为List.
Each copy of the Basetab needs to be named each value contained on the Listtab. Cell C1on Baseneeds to be set to the value from the array List(which will also be the name of the tab).
Base选项卡的每个副本都需要命名List选项卡上包含的每个值。Cell C1onBase需要设置为数组中的值List（这也是选项卡的名称）。
The list will contain 300ish values, and having each tab in workbook as a copy of the original will oddly be the best solution for what will be a shared workbook.
该列表将包含 300 个左右的值，并且将工作簿中的每个选项卡作为原始选项卡的副本将奇怪地成为共享工作簿的最佳解决方案。
I would like to flatten each worksheet to static values. Each worksheet with have a number of formulas that will cause performance issues if I leave as dynamic content.
我想将每个工作表展平为静态值。每个工作表都有许多公式，如果我保留为动态内容，这些公式会导致性能问题。
Here is my code.
这是我的代码。
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
After trying the solution, the only change is that I would like to re-calc the whole sheet (the functional equivalent of pushing the F9 key) after the new sheet is pasted but right before the sheet is flattened. I assume a line of code needs to be inserted as indicated below in the LetUsContinue 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
回答by Jerome Montino
Try this:
尝试这个：
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
Screenshots:
截图：
Set-up:
设置：
Result after running code:
运行代码后的结果：
Read the comments. Hope this helps. :)
阅读评论。希望这可以帮助。:)
