Excel VBA - Как проверить, является ли цель именованным диапазоном.Если да, вставьте диапазон

Question

В настоящее время мой код Excel используется для выполнения следующих действий:

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

Вместо того, чтобы вводить каждый триггерный термин и соответствующий именованный диапазон в коде ..... есть ли способ сделать его динамическим?

IF target = "ANY named range", ТО затем вставьте именованный диапазон

Вот фрагмент текущего кода.Мой список именованных диапазонов будет расти, поэтому этот метод не будет осуществим, когда список именованных диапазонов станет слишком большим.Поддерживать это будет больно, поэтому моя просьба здесь:

**Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    Application.EnableEvents = True
    If Target = "Crew_Key_Non_Prompt" Then
        Sheet1.Range("Crew_Key_Non_Prompt").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Key_Prompt" Then
        Sheet1.Range("Crew_Key_Prompt").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Key_Target" Then
        Sheet1.Range("Crew_Key_Target").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Speed" Then
        Sheet1.Range("Crew_Speed").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Speed_Overspeed" Then
        Sheet1.Range("Crew_Speed_Overspeed").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Train_Orientation" Then
        Sheet1.Range("Crew_Train_Orientation").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Crew_Verbal_Confirmation" Then
        Sheet1.Range("Crew_Verbal_Confirmation").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Dispatcher_Action" Then
        Sheet1.Range("Dispatcher_Action_button").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Fence_Validation" Then
        Sheet1.Range("Fence_Validation").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Fence_Validation" Then
        Sheet1.Range("Fence_Validation").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Set_Device" Then
        Sheet1.Range("Set_Device").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Train_Switch_Navigation" Then
        Sheet1.Range("Train_Switch_Navigation").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Train_Target_Approach" Then
        Sheet1.Range("Train_Target_Approach").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Train_Target_Interaction" Then
        Sheet1.Range("Train_Target_Interaction").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
    ElseIf Target = "Train_Timed_Movement" Then
        Sheet1.Range("Train_Timed_Movement").Copy
        Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
        End If
     End If
  Application.EnableEvents = True
  Application.CutCopyMode = False
 End Sub**

Answer 1

Хотя использование On Error Resume Next обычно не рекомендуется, это может быть исключением.Если в Sheet1 нет именованного диапазона, соответствующего значению, введенному в Target, копирование / вставка не выполняется.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then
        Application.EnableEvents = False

        On Error Resume Next
        Sheet1.Range(Target.Value).Copy Target.Offset(-1,1)

        Application.EnableEvents = True
    End If
End sub

Answer 2

Если именованные диапазоны представляют собой отдельные ячейки или формулы, то будет работать что-то вроде этого:

Private Function getValueFromNamedRange(strName As String, Optional wb As Workbook) As Variant
    'Locally scoped names must include "<sheetName>!"
    Dim n As Name
    On Error GoTo uhoh
    If wb Is Nothing Then Set wb = ThisWorkbook
    For Each n In wb.Names
        If n.Name = strName Then getValueFromNamedRange = Evaluate(n.RefersTo): Exit Function
    Next
uhoh:
    getValueFromNamedRange = ""
End Function

Sub test()
    Dim s As String
    s = getValueFromNamedRange("TEST")
    If s <> "" Then MsgBox s
End Sub

Answer 3

Некоторые функции, подобные этой, вероятно, жизнеспособны:

Public Function amInamedRange(myName As String, ws As Worksheet) As Boolean

    On Error GoTo amInamedRange_Error

    If ws.Range(myName) <> "" Then
    End If
    amInamedRange = True

    On Error GoTo 0
    Exit Function

amInamedRange_Error:
    amInamedRange = False
    On Error GoTo 0

End Function

А вот несколько возможных вариантов использования:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        Application.EnableEvents = False
        If amInamedRange(Target.Value2, Target.Parent) Then
            Sheet1.Range(target).Copy
            Cells(Target.Row, 1).Offset(-1, 2).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
        Application.EnableEvents = True
    End If

End Sub