Значение текстового поля автоинкремента VBA Excel при создании нового листа

Question

Я хотел бы сделать значения в текстовом поле более гибкими. Поэтому, когда я создаю новый лист, я хочу, чтобы их значения были увеличены на указанное число.

Пока что на основе этого решения я использовал следующий код:

 Sub CivBoxNext()
 With ActiveSheet
   Range("D51").Select
   .Shapes("Civils 3").TextFrame2.TextRange.Characters.Text = ActiveCell.Value + 2
    Range("D52").Select
   .Shapes("Civils 4").TextFrame2.TextRange.Characters.Text = ActiveCell.Value + 2
  End With
 End Sub

, который затем я построил в коде, создающем новый лист как Call метод:

Sub Civilssheet()

Dim I As Long
Dim xNumber As Integer
Dim xName As String
Dim xActiveSheet As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Set xActiveSheet = ActiveSheet
xNumber = InputBox("Enter number of times to copy the current sheet")
For I = 1 To xNumber
    xName = ActiveSheet.Name
    xActiveSheet.Copy After:=ActiveWorkbook.Sheets("Civils2")
    ActiveSheet.Name = "Civils" & I + 2
Next
Call CivBoxNext
xActiveSheet.Activate
Application.ScreenUpdating = True


End Sub

Это работает, но только на одном следующем листе. После этого у меня есть еще 3 листа, нумерация которых должна измениться в тот же момент.

Я попробовал другой вариант, например, изменить значение целевой ячейки, когда обрабатывать новый лист и затем подавать мое текстовое поле из этой ячейки. Для этого я использовал следующий код:

 Private Sub Workbook_NewSheet(ByVal Sh As Object)
 Dim ws As Worksheet
 j = 0
 For Each ws In Worksheets

    I = ws.Range("D51").Value

    If I > j Then
        j = I
    End If

  Next
 ActiveSheet.Range("D51").Value = j + 2
 End Sub

, который исходит отсюда: https://www.mrexcel.com/board/threads/auto-increase-a-cell-value-1-when-a-new-sheet-is-created.334786/

, но не работает.

Может Кто-нибудь совет, как сделать автоинкремент значения ячейки при создании нового листа? Должен ли я сразу поиграть с традиционными формулами Excel вместо VBA?

Спасибо

Answer 1

Это объединит ваши подводные лодки. Можете ли вы увидеть, соответствует ли он вашим потребностям?

Sub Civilssheet()

    Application.ScreenUpdating = False

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Civils9")
    Dim I As Long
    Dim xNumber, valCivics, valCivicsFin As Integer

    xNumber = InputBox("Enter number of times to copy the current sheet")

    On Error Resume Next

    ' extract highest Civics worksheet number
    For I = 1 To ActiveWorkbook.Sheets.Count
        If InStr(1, Sheets(I).Name, "Civils") > 0 Then
            valCivics = Val(Replace(Sheets(I).Name, "Civils", ""))
            If valCivics > valCivicsFin Then valCivicsFin = valCivics
        End If
    Next

    For I = 1 To xNumber
        ' add worksheet to the end of existing worksheets
        ws.Copy After:=Sheets(Application.Sheets.Count)
        ' name the new worksheet with the highest value + 1
        ActiveSheet.Name = "Civils" & I + valCivicsFin
        ActiveSheet.Shapes("Civils 3").TextFrame2.TextRange.Characters.Text = ActiveSheet.Cells(51, 4).Value + 2
        ActiveSheet.Shapes("Civils 4").TextFrame2.TextRange.Characters.Text = ActiveSheet.Cells(52, 4).Value + 2
    Next

    Application.ScreenUpdating = True
End Sub