单元格（范围内）更改后创建新工作表

Posted 2023-02-25

【中文标题】单元格（范围内）更改后创建新工作表

【英文标题】：create new worksheet after cell (in a range) change

【发布时间】：2016-12-29 13:30:11

【问题描述】：

我有单元格 A2 到 A20 希望在该范围内的单元格值发生变化时生成新工作表。

此外，生成的新工作表将被重命名为更改单元格的值。

我让这段代码正常工作（对于单个单元格），直到用户请求该范围

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim ws As Worksheet
Dim lastrow As Long
lastrow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1
Set KeyCells = Range("B5")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
       Is Nothing Then
For Each ws In Worksheets
With ActiveSheet
    If .Range("B5").Value <> "" Then .Name = .Range("B5").Value
End With
Cells(lastrow, "D").Value = Range("B5").Value
End If

结束子

【参考方案1】：

一旦Range("A2:A20") 中的值发生更改，以下代码将创建一个新工作表，新工作表名称等于单元格值。

该代码还验证没有具有该名称的现有工作表（这将导致错误）。

代码

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells As Range
Dim ws As Worksheet
Dim lastrow As Long

' you are not doing anything currently with the last row
'lastrow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row + 1

' according to your post you are scanning Range A2:A20 (not B5)
Set KeyCells = Range("A2:A20")

If Not Intersect(KeyCells, Target) Is Nothing Then
    For Each ws In Worksheets
        ' if sheet with that name already exists
        If ws.Name = Target.Value Then
            MsgBox "A Worksheet with Cell " & Target.Value & " already exists"
            Exit Sub
        End If                  
    Next ws

    Set ws = Worksheets.Add
    ws.Name = Target.Value        
End If

End Sub

【讨论】：

完美。谢谢。 lastrow 和 A2:A20 是其他请求的一部分。感谢您的忽略。