Question

我目前已将我的Excel编码为执行以下操作：

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

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

IF target =“任何命名范围” 然后粘贴命名范围

这是当前代码的摘要。我最终的命名范围列表将不断增长，因此，当命名范围列表太大时，此方法将不可行。维护起来很痛苦，因此我在这里的要求是：

**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中输入的值相对应的命名范围，则不会发生复制/粘贴。

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 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-如何检查目标是否为命名范围。如果是，粘贴范围

3 个答案: