VBA:复制整个工作表

Question

我有一个工作簿，一个主索引表和一个模板表。
我的索引表中有信息。
主工作表中的每一行都应该生成一个新工作表。
我想复制模板与所有的数据在那里，但从主表的每一行的名称。
我可以创建具有正确名称的表单，但其中没有数据。

这是VBA代码，使一个新的工作表与正确的名称。我需要把所有的数据复制到所有的新表格中。它来自Oscar Cronquist的博客文章:

'Name macro
Sub CreateSheets()
'Dimension variables and declare data types
Dim rng As Range
Dim cell As Range
'Enable error handling
On Error GoTo Errorhandling
'Show inputbox to user and prompt for a cell range
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, _
Type:=8)
'Iterate through cells in selected cell range
For Each cell In rng
'Check if cell is not empty
If cell <> "" Then
'Insert worksheet and name the worksheet based on cell value
Sheets.Add.Name = cell
End If
'Continue with next cell in cell range
Next cell
'Go here if an error occurs
Errorhandling:
'Stop macro
End Sub

Answer 1

创建模板工作表

Sub CreateTemplateWorksheets()

Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ash As Object: Set ash = wb.ActiveSheet

Dim lws As Worksheet: Set lws = wb.Worksheets("Main Index")
Dim lrg As Range
Set lrg = lws.Range("A2", lws.Cells(lws.Rows.Count, "A").End(xlUp))

Dim sws As Worksheet: Set sws = wb.Worksheets("Template")

Dim lCell As Range
Dim dws As Worksheet
Dim dwsCount As Long
Dim dName As String

For Each lCell In lrg.Cells
dName = CStr(lCell.Value)
If Len(dName) > 0 Then
On Error Resume Next
Set dws = wb.Worksheets(dName)
On Error GoTo 0
If dws Is Nothing Then
sws.Copy After:=wb.Sheets(wb.Sheets.Count)
Set dws = ActiveSheet
dws.Name = dName
dwsCount = dwsCount + 1
End If
Set dws = Nothing
End If
Next lCell

ash.Select

MsgBox "Worksheets created: " & dwsCount, vbInformation
End Sub