Question

我正在努力实现以下目标。

当我在＆＃39; Master＆＃39;上输入值时范围A5中的工作表：A50，运行一个宏，创建一个与该值同名的新工作表，然后将模板复制到新工作表上。

除此之外，我还想将主工作表上输入值旁边的值复制到这个新工作表中，以便自动进行计算。

例如我输入＆＃39; 1＆＃39;在A5和＆＃39; 2＆＃39;在B5。我想创建一个名为＆＃39; 1＆＃39;的新工作表，复制模板＆＃39;模板＆＃39;工作表并将B5的值复制到名为＆＃39; 1＆＃39;的新工作表上。

我有以下代码，但它也尝试复制模板工作表与宏运行导致错误，因为工作表名称为＆＃39;模板＆＃39;已经存在。

Sub CreateAndNameWorksheets()
    Dim c As Range

    Application.ScreenUpdating = False
    For Each c In Sheets("Master").Range("A5:A50")
        Sheets("Template").Copy After:=Sheets(Sheets.Count)
        With c
            ActiveSheet.Name = .Value
            .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                "'" & .Text & "'!A1", TextToDisplay:=.Text
        End With
    Next c
    Application.ScreenUpdating = True
 End Sub

Answer 1

右键单击主工作表的名称标签，然后选择查看代码。当VBE打开时，将以下内容粘贴到标题为 Book1 - Master（Code）的窗口中。

Private Sub Worksheet_Change(ByVal target As Range)
    If Not Intersect(target, Rows("5:50"), Columns("A:B")) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        Dim r As Long, rw As Long, w As Long
        For r = 1 To Intersect(target, Rows("5:50"), Columns("A:B")).Rows.Count
            rw = Intersect(target, Rows("5:50"), Columns("A:B")).Rows(r).Row
            If Application.CountA(Cells(rw, 1).Resize(1, 2)) = 2 Then
                For w = 1 To Worksheets.Count
                    If LCase(Worksheets(w).Name) = LCase(Cells(rw, 1).Value2) Then Exit For
                Next w
                If w > Worksheets.Count Then
                    Worksheets("Template").Visible = True
                    Worksheets("Template").Copy after:=Sheets(Sheets.Count)
                    With Sheets(Sheets.Count)
                        .Name = Cells(rw, 1).Value2
                        .Cells(1, 1) = Cells(rw, 2).Value
                    End With
                End If
                With Cells(rw, 1)
                    .Parent.Hyperlinks.Add Anchor:=Cells(rw, 1), Address:="", _
                        SubAddress:="'" & .Value2 & "'!A1", TextToDisplay:=.Value2
                End With
            End If
        Next r
        Me.Activate
    End If
bm_Safe_Exit:
    Worksheets("Template").Visible = xlVeryHidden
    Me.Activate
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

请注意，这取决于您是否拥有名为模板的工作表以生成新工作表。它还保留了模板工作表xlVeryHidden，这意味着如果您尝试取消隐藏它，它将不会显示。进入VBE并使用“属性”窗口（例如F4）将可见性设置为可见。

此例程应该能够在将多个值粘贴到A2：B50后继续存在，但它会丢弃已存在的A列中的建议工作表名称。在继续之前，任何一行的A列和B列都必须有一个值。

目前没有检查非法工作表名称字符。您可能希望熟悉这些并添加一些错误检查。

Answer 2

与帖子标题相关但与具体应用无关的另一个示例。代码更新主列表中的工作表，如果模板不存在，则从模板创建工作表。

其他参考：https://stackoverflow.com/a/18411820/9410024。

Sub UpdateTemplateSheets()
    ' Update sheets in list created from a template
    ' 
    ' Input: List on master sheet, template sheet
    ' Output: Updated sheet from template for each item in list
    '
    Dim wsInitial As Worksheet
    Dim wsMaster As Worksheet
    Dim wsTemp As Worksheet
    Dim lVisibility As XlSheetVisibility
    Dim strSheetName As String
    Dim rIndex As Long
    Dim i As Long

    On Error GoTo Safe_Exit
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    ' Application.Calculation = xlCalculationManual

    Set wsInitial = ActiveSheet
    Set wsMaster = Sheets("Summary")
    Set wsTemp = Sheets("Template")

    lVisibility = wsTemp.Visible          ' In case template sheet is hidden
    wsTemp.Visible = xlSheetVisible

    For rIndex = 2 To wsMaster.Cells(Rows.Count, "A").End(xlUp).Row
        ' Ensure valid sheet name
        strSheetName = wsMaster.Cells(rIndex, "A").Text
        For i = 1 To 7
            strSheetName = Replace(strSheetName, Mid(":\/?*[]", i, 1), " ")
        Next i
        strSheetName = Trim(Left(WorksheetFunction.Trim(strSheetName), 31))

        ' Ensure sheet name doesn't already exist
        If Not Evaluate("IsRef('" & strSheetName & "'!A1)") Then
            wsTemp.Copy after:=Sheets(Sheets.Count)
            With Sheets(Sheets.Count)
                .Name = strSheetName
            End With
        End If
        With Sheets(strSheetName)
            .Range("B59").Value = rIndex * 16 + 1        ' Update template block option row
        End With
    Next rIndex

Safe_Exit:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    'Application.Calculation = xlCalculationAutomatic
    wsInitial.Activate
    wsTemp.Visible = lVisibility  ' Set template sheet to its original visible state

End Sub

根据excel中的列表自动创建工作表

2 个答案: