Excel InputBox: назовите фигуры уникальными именами

Этот код позволяет добавить две фигуры «овал» в выбранный диапазон ячеек и переименовать фигуры.

Он использует 3 поля ввода:

«1/3 выбора диапазона формы»
«2/3 Введите имя формы shp1»
«3/3 Введите имя формы shp2»

Как создать поле ввода «Введите имя фигуры»-InputBox, чтобы обеспечить уникальное имя для каждой фигуры и иметь MsgBox с надписью «Это имя уже занято»?

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_v3()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title: = "1/3 Select Shape Range", _
                               Prompt: = "", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
        .Name = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                     Default: = "Click L1 ", _
                                     Prompt: = "", _
                                     Type:=2)
        .Shadow.Visible = False
        .Fill.Visible = True
        .Fill.ForeColor.RGB = vbGreen
        .Line.Visible = False
        .Line.ForeColor.RGB = vbGreen
        .Line.Weight = LWT
        .Line.Transparency = 0
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
        .Name = Application.InputBox(Title: = "3/3 Enter Name Level 2", _
                                     Default: = "Click L2 ", _
                                     Prompt: = "", _
                                     Type:=2)
        .Shadow.Visible = False
        .Fill.Visible = True
        .Fill.ForeColor.RGB = vbGreen
        .Line.Visible = False
        .Line.ForeColor.RGB = vbGreen
        .Line.Weight = LWT
        .Line.Transparency = 0
    End With  
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

РЕДАКТИРОВАТЬ

@taller представляет два решения.

Это первое решение, использующее:

«Добавьте UDF для проверки ввода пользователя».
«Другой вариант УДФ»

У пользователя есть одна попытка присвоить фигурам уникальное имя. Два окна сообщений информируют пользователя. MsgBox 1: если введенное имя повторяется, пользователю будет предложено повторить попытку. MsgBox 2: если повторная попытка не удалась, пользователю будет предложено перезагрузить компьютер. Все работает идеально.

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3 UPDATE v0
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_000_v3_UPDATE_v0()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title: = "1/3 Select Shape Range", _
                               Prompt: = "", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
        Dim sName As String
        sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                     Default: = "Click L1 ", _
                                     Prompt: = "", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated."  _
            & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                         Default: = "Click L1 ", _
                                         Prompt: = "", _
                                         Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
'        Dim sName As String
        sName = Application.InputBox(Title: = "3/3 Enter Name Level 2", _
                                     Default: = "Click L2 ", _
                                     Prompt: = "", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated."  _
            & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            sName = Application.InputBox(Title: = "3/3 Enter Name Level 2", _
                                         Default: = "Click L2 ", _
                                         Prompt: = "", _
                                         Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart" 
            .Delete
        End If
    End With
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function
'========================================================================

Это второе решение, использующее:

«Пользователь может повторить попытку X раз»

Пользователь имеет X попыток присвоить фигурам уникальное имя.

Проблема: Подсказка shp-1 «попробуйте еще раз» работает правильно. Подсказка shp-2 «попробуй еще раз» имеет неограниченное количество повторов.

Option Explicit

'========================================================================
' InputBox: Add Shapes for Buttons v3 UPDATE v1
'========================================================================
' Buttons: 2
' Cell Size: Width 47
' Button Size: DIA
' Line Weight: LWT
' Shape Type: msoShapeOval, No 9
'========================================================================

Sub IPB_AddShapes_Buttons_000_v3_UPDATE_v1()

Dim ws As Worksheet

Dim rng As Range
Dim shp1 As Shape
Dim shp2 As Shape

Const DIA As Single = 9
Const LWT As Single = 1

Dim sName As String, iCnt As Long
Const MAX_TRY = 3  ' max tries

On Error Resume Next

Set ws = ActiveSheet

Set rng = Application.InputBox(Title: = "1/3 Select Shape Range", _
                               Prompt: = "", _
                               Type:=8)

  Set shp1 = ws.Shapes.AddShape(9, _
                                rng.Left + 5, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp1
'        Dim sName As String, iCnt As Long
'        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated."  _
                & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            End If
            sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                         Default: = "Click L1 ", _
                                         Prompt: = "", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If        
    End With
    
  Set shp2 = ws.Shapes.AddShape(9, _
                                rng.Left + 19, _
                                rng.Top + ((rng.Height - DIA) / 2), _
                                DIA, _
                                DIA)
    With shp2
'        Dim sName As String, iCnt As Long
'        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated."  _
                & vbCrLf & "Please try again.", vbExclamation, "Duplicate"
            End If
            sName = Application.InputBox(Title: = "3/3 Enter Name Level 2", _
                                         Default: = "Click L2 ", _
                                         Prompt: = "", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is already taken."  _
            & vbCrLf & "Please restart.", vbExclamation, "Restart"
            .Delete
        End If
    End With
    
  MsgBox "Shape Names:" & vbNewLine & vbNewLine & _
               "" & shp1.Name & vbNewLine & _
               "" & shp2.Name, , ""
    
End Sub
'========================================================================

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function
'========================================================================

excel vba shapes names inputbox

06.05.2024 20:02

Преобразование HTML-таблицы в профессиональный документ Excel

Это самый простой способ создания Excel из HTML-таблицы.

Импорт excel в laravel в базу данных

Здравствуйте, дорогой читатель, в этой статье я расскажу практическим и быстрым способом, как импортировать файл Excel в вашу базу данных с помощью...

118

Перейти к ответу Данный вопрос помечен как решенный

Ответы 1

Ответ принят как подходящий

Добавьте UDF для проверки ввода пользователя.

Sub IPB_AddShapes_Buttons_v3()
    ' your code ...
    
    With shp1
        Dim sName As String
        sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                     Default: = "Click L1 ", _
                                     Prompt: = "", _
                                     Type:=2)
        If Not ValidateName(sName) Then
            MsgBox "Shape name [" & sName & "] is duplicated. Try again."
            sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                             Default: = "Click L1 ", _
                             Prompt: = "", _
                             Type:=2)
        End If
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is duplicated"
            .Delete
        End If
    End With
    
    ' your code ...
    
End Sub

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    ShpName = UCase(ShpName)
    For Each s In ActiveSheet.Shapes
        If UCase(s.Name) = ShpName Then
            ValidateName = False
            Exit Function
        End If
    Next
    ValidateName = True
End Function

Пользователь может повторить попытку X раз

    With shp1
        Dim sName As String, iCnt As Long
        Const MAX_TRY = 3  ' max tries
        Do
            If Len(sName) > 0 Then
                MsgBox "Shape name [" & sName & "] is duplicated." & vbCrLf & "Please try again."
            End If
            sName = Application.InputBox(Title: = "2/3 Enter Name Level 1", _
                                         Default: = "Click L1 ", _
                                         Prompt: = "", _
                                         Type:=2)
            iCnt = iCnt + 1
        Loop Until ValidateName(sName) Or iCnt = MAX_TRY
        If ValidateName(sName) Then
            .Name = sName
            .Shadow.Visible = False
            .Fill.Visible = True
            .Fill.ForeColor.RGB = vbGreen
            .Line.Visible = False
            .Line.ForeColor.RGB = vbGreen
            .Line.Weight = LWT
            .Line.Transparency = 0
        Else
            MsgBox "Shape name [" & sName & "] is duplicated"
            .Delete
        End If
    End With

Другой вариант УДФ

Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function

И как бы вы включили подсказку «попробуйте еще раз» после предупреждения «дубликат»?

— 06.05.2024 21:47

Обновленный код предоставляет пользователям больше возможностей повторных попыток.

— 06.05.2024 22:04

Как изменить параметр «Пользователь может повторить попытку X раз», чтобы он работал для обеих фигур?

— 07.05.2024 23:33

Дубликат With shp1 ... End With. Измените shp1 > shp2 и аргументы поля ввода.

— 08.05.2024 00:36

06.05.2024 20:15