根据匹配单元格旁边的单元格中的下拉列表插入值 [英] Insert value based on drop down list from cell next to matched one

问题描述

我有一个示例表(B2:C4)，具有两个定义的值"XXX = 10，YYY = 20，ZZZ = 30".

I have a sample table (B2:C4) with a couple of defined values "XXX = 10, YYY = 20, ZZZ = 30".

我在"E"列中有第二个表(E2:F10)，其中带有下拉列表.

I have the second table (E2:F10) with drop down list in the column "E".

我需要将基于下拉列表的值复制到"F"列.例如，这意味着当我选择E3 ="XXX"时，从下拉列表中，它从列"C"中复制适当的值.在所附图片的示例中，B1 ＝"XXX".->C1 ＝"10".因此该值将被复制到F3).

I need to copy value based on drop down list to column "F". It means for example when I select E3 = "XXX" from drop down list it copies appropriate value from column "C". In the example on the attached picture B1 = "XXX" -> C1 = "10" so the value will be copied to F3).

问题在于，下拉列表还包括除"B2:B4"列中的其他项之外的其他项.因此我可以自定义表格中的条目.

The problem is that the drop down list includes also another items than in the column "B2:B4" so I can customize the entry in the table.

我创建了工作代码，但问题是当我更改C2:C4列中的任何值时，F2:F10列中的值不会更改.

I created working code but the issue is when I change any value in the column C2:C4 the value in the column F2:F10 does not change.

任何帮助将不胜感激.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Res As Variant
   If Target.CountLarge > 1 Then Exit Sub
   If Not Intersect(Target, Range("E2:E10")) Is Nothing Then
      Res = Evaluate("INDEX(C2:C4,MATCH(" & Target.Address & ",B2:B4,0))")
      If Not IsError(Res) Then Target.Offset(, 1) = Res
   End If
End Sub

样本XLSM文件

这是我根据@Variatus编辑示例表和代码的方式:

This is how I edited the sample table and the code according @Variatus:

模块代码:

Enum Nws                    ' worksheet where 'Data' values are used
    ' 060
    NwsFirstDataRow = 7     ' change to suit
    NwsTrigger = 6          ' Trigger column (5 = column E)
    NwsTarget = 8              ' Target column (no value = previous + 1)
End Enum

Enum Nta                    ' columns of range 'Data'
    ' 060
    NtaId = 1
    NtaVal = 3
End Enum

以及工作表代码:

    Option Explicit

    Private Sub Worksheet_Change(ByVal Target As Range)
        ' 060
        
        Dim Ws          As Worksheet        ' the sheet on which the "Data" range resides
        Dim Rng         As Range
        Dim Tmp         As Variant
        
        ' skip action if more than 1 cell was changed
        If Target.CountLarge > 1 Then Exit Sub
        
        Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
                        Cells(Rows.Count, NwsTrigger).End(xlUp))
        If Not Application.Intersect(Target, Rng) Is Nothing Then
            Set Ws = ThisWorkbook.Sheets("test")    ' change to match your facts
            Set Rng = Ws.Range("B2:D4")             ' change to match your facts
            With Application
                Tmp = .VLookup(Target.Value, Rng, 3, False)
                If Not IsError(Tmp) Then
                    .EnableEvents = False   ' suppress 'Change' event
                    Cells(Target.Row, NwsTarget).Value = Tmp
                    .EnableEvents = True
                End If
            End With
        End If
        
        ' skip action if more than one cell was changed
    If Target.CountLarge > 1 Then Exit Sub
    
    If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
        UpdateCategory Target.Offset(0, -1).Resize(, 2).Value
    End If
        
        
    End Sub

Private Sub Worksheet_Deactivate()
    ' 060
    
    Dim TgtWs           As Worksheet        ' the Tab on which 'Data' was used
    Dim Cat             As Variant          ' 'Data' category (2 cells as Nta)
    Dim R               As Long             ' loop counter: rows
    Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
    
    With Range("B2:D4")                      ' change to match your facts
        For R = 1 To .Rows.Count
            Cat = .Rows(R).Value
            UpdateCategory Cat
        Next R
    End With
End Sub



Private Sub UpdateCategory(Cat As Variant)
    ' 060
    
    Dim TgtWs           As Worksheet        ' the Tab on which 'Data' was used
    Dim Fnd             As Range            ' matching cell
    Dim FirstFound      As Long             ' row of first match
    Dim Rng             As Range
    
    Set TgtWs = ThisWorkbook.Sheets("test") ' change to match your facts
    Application.EnableEvents = False
    With TgtWs
        Set Rng = .Range(.Cells(NwsFirstDataRow, NwsTrigger), _
                         .Cells(.Rows.Count, NwsTrigger).End(xlUp))
        With Rng
             Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
             If Not Fnd Is Nothing Then
                FirstFound = Fnd.Row
                Do
                    TgtWs.Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
                    Set Fnd = .FindNext(Fnd)
                    If Fnd Is Nothing Then Exit Do
                Loop While Fnd.Row <> FirstFound
            End If
        End With
    End With
    Application.EnableEvents = True
End Sub

推荐答案

以下代码在以下方面与所选答案不同.

The code below differs from the selected answer in the following respects.

1. 所有动作现在都按照您的原始问题在一张纸上进行.因此，现在必须将所有代码放置在工作表的代码表上所有发生的地方.因此，所有工作表规范都可以从代码中删除.
2. 在 Data 范围内插入了一个额外的列，但是，如枚举 Nta 中所标识的，仅使用了第一列和第三列.

1. All the action now takes place on one sheet, as per your original question. Therefore all the code must now be placed in one location, on the code sheet of the worksheet on which everything transpires. In consequence thereof all worksheet specification could be removed from the code.
2. An extra column was interjected in the Data range of which, however, only the first and third columns are used, as identified in the Enum Nta.

显式选项

Enum Nws                    ' worksheet where 'Data' values are used
    ' 060-2
    NwsFirstDataRow = 2     ' change to suit
    NwsTrigger = 5          ' Trigger column (5 = column E)
    NwsTarget               ' Target column (no value = previous + 1)
End Enum

Enum Nta                    ' columns of range 'Data'
    ' 060
    NtaId = 1               ' 1st column of 'Data' range
    NtaVal = 3              ' 3rd column of 'Data' range
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 060-2
    
    Dim Rng         As Range
    Dim Tmp         As Variant
    
    ' skip action if more than 1 cell was changed
    If Target.CountLarge > 1 Then Exit Sub
    
    Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
                    Cells(Rows.Count, NwsTrigger).End(xlUp))
    If Not Application.Intersect(Target, Rng) Is Nothing Then
        With Application
            Tmp = .VLookup(Target.Value, Range("Data"), NtaVal, False)
            If Not IsError(Tmp) Then
                .EnableEvents = False       ' suppress 'Change' event
                Cells(Target.Row, NwsTarget).Value = Tmp
                .EnableEvents = True
            End If
        End With
    Else
        Set Rng = Range("Data")             ' change to suit
        If Not Application.Intersect(Target, Rng.Columns(NtaVal)) Is Nothing Then
            UpdateCategory Cells(Target.Row, Rng.Column).Resize(1, NtaVal).Value
        End If
    End If
End Sub
    
Private Sub Worksheet_activate()
    ' 060-2
    
    Dim TgtWs           As Worksheet        ' the Tab on which 'Data' was used
    Dim Cat             As Variant          ' 'Data' category (2 cells as Nta)
    Dim R               As Long             ' loop counter: rows
    Set TgtWs = Sheet1                      ' change to match your facts
    
    With Range("Data")                      ' change to match your facts
        For R = 1 To .Rows.Count
            Cat = .Rows(R).Value
            UpdateCategory Cat
        Next R
    End With
End Sub

Private Sub UpdateCategory(Cat As Variant)
    ' 060-2
    
    Dim Fnd             As Range            ' matching cell
    Dim FirstFound      As Long             ' row of first match
    Dim Rng             As Range
    
    Application.EnableEvents = False
    Set Rng = Range(Cells(NwsFirstDataRow, NwsTrigger), _
                     Cells(Rows.Count, NwsTrigger).End(xlUp))
    With Rng
         Set Fnd = .Find(Cat(1, NtaId), LookIn:=xlValues, LookAt:=xlWhole)
         If Not Fnd Is Nothing Then
            FirstFound = Fnd.Row
            Do
                Cells(Fnd.Row, NwsTarget).Value = Cat(1, NtaVal)
                Set Fnd = .FindNext(Fnd)
                If Fnd Is Nothing Then Exit Do
            Loop While Fnd.Row <> FirstFound
        End If
    End With
    Application.EnableEvents = True
End Sub

这篇关于根据匹配单元格旁边的单元格中的下拉列表插入值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！