根据列表中的信息填充新模板

Question

Excel 从两张纸开始。
首先是一个包含名称、编号和产品编号数据的列表。
第二个选项卡是一个模板。

我试着：
复制模板选项卡，在新选项卡中输入名称、编号和产品，然后重命名选项卡 (ActiveSheet.Name = Range("B3").Value)。
循环到下一行并重复，直到没有更多行。
如果已存在具有名称的选项卡，则移至下一行。

我尝试了两种方法。

下面的代码我可能会弄清楚，但它需要我复制和粘贴相同的行和更新的行大约 100 次，因为它没有循环。
此外，如果已经有一个带有名称的选项卡而不是继续，则宏会停止。

如果已经从列表中的名称创建了一个选项卡，我做了几次尝试让宏继续运行，但这会一直破坏宏。

Sub TemplateMultiple()
'
' Tab creation and naming
'

'
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(2)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!RC[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(3)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[0]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(4)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[4]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[1]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(5)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[5]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[2]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
    
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(6)
    Range("B3:C3").Select
    ActiveCell.FormulaR1C1 = "='List'!R[6]C"
    Range("B5:C5").Select
    ActiveCell.FormulaR1C1 = "='List'!R[4]C[3]"
    Range("B6:C6").Select
    ActiveCell.FormulaR1C1 = "='List'!R[3]C[4]"
    Range("B7:C7").Select
    ActiveSheet.Name = Range("B3").Value
End Sub

第二种方法涉及一个循环，使代码更容易阅读/遵循。
我的代码将相同的信息放入每个模板中，而不是为每个电子表格向下一行。

Sub Template1()
'UpdatebyExtendoffice20161222
    Dim x As Integer
    Application.ScreenUpdating = False
    ' Set numrows = number of rows of data.
    NumRows = Range("B5", Range("B5").End(xlDown)).Rows.Count
    ' Select cell a1.
    Range("B5").Select
    ' Establish "For" loop to loop "numrows" number of times.
    For x = 1 To NumRows
        ' Insert your code here.
        Sheets("Template").Select
        Sheets("Template").Copy Before:=Sheets(2)
        Range("B3:C3").Select
        ActiveCell.FormulaR1C1 = "='List'!R[2]C"
        Range("B5:C5").Select
        ActiveCell.FormulaR1C1 = "='List'!RC[3]"
        Range("B6:C6").Select
        ActiveCell.FormulaR1C1 = "='List'!R[-1]C[4]"
        Range("B7:C7").Select
        ActiveSheet.Name = Range("B3").Value
        ' Selects cell down 1 row from active cell.
        ActiveCell.Offset(1, 0).Select
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

像这样的东西应该工作：

Sub Template1()

    Dim wb As Workbook, ws As Worksheet, wsList As Worksheet
    Dim c As Range, sheetName As String, wsTempl As Worksheet
    
    Set wb = ThisWorkbook
    Set wsList = wb.Worksheets("List")
    Set wsTempl = wb.Worksheets("Template")
    
    Application.ScreenUpdating = False
    
    For Each c In wsList.Range("B5", wsList.Cells(Rows.Count, "B").End(xlUp)).Cells
        sheetName = c.Value
        Set ws = GetWorksheet(wb, sheetName) 'see if there's an existing sheet with this name
        If ws Is Nothing Then                'if was no matching sheet
            wsTempl.Copy before:=wsTempl     'copy template in front of itself
            Set ws = wb.Worksheets(wsTempl.Index - 1) 'get a reference to the copy
            ws.Name = sheetName
            With c.EntireRow
                'I never use R1C1 so this might be off...
                ws.Range("B3:C3").Formula = "='List'!" & .Columns("B").Address(False, False)
                ws.Range("B5:C5").Formula = "='List'!" & .Columns("E").Address(False, False)
                ws.Range("B6:C6").Formula = "='List'!" & .Columns("E").Address(False, False)
            End With
        End If
    Next c
    
    Application.ScreenUpdating = True
End Sub

'Return a worksheet named `wsName` from workbook `wb`, or `Nothing` if it doesn't exist
Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
    On Error Resume Next
    Set GetWorksheet = wb.Worksheets(wsName)
    On Error Goto 0
End Function

请注意，在使用它们之前很少需要选择/激活它们 - 这是宏记录器的工件。 请参阅How to avoid using Select in Excel VBA 了解更多信息和一些好的指导方针。