Excel VBA - 如何检查目标是否为命名范围。如果是，粘贴范围

Question

我目前将 excel 编码为执行以下操作：

只要在 B 列的任意位置键入各种特定的文本字符串，就会在相对偏移处粘贴相应的命名范围。

而不是在代码中键入每个触发项和相应的命名范围......有没有办法让它动态化？

IF 目标 = "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

像这样的一些功能可能是可行的：

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

Answer 2

虽然通常不鼓励使用 On Error Resume Next，但这可能是一个例外。如果 Sheet1 上没有与 Target 中输入的值相对应的命名范围，则不会出现 copy/paste。

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)
        On Error GoTo 0

        Application.EnableEvents = True
    End If
End sub

Answer 3

如果命名范围是单个单元格或公式，那么这样的事情会起作用：

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

Excel VBA - 如何检查目标是否为命名范围。如果是，粘贴范围

Excel VBA - How to check if target is a named range. If yes, paste range

excel

vba

dynamic

range

named