如果列名匹配数据验证，则扩展 VB 代码以填充 Excel 单元格

Question

我们目前在 Excel 工作簿中有一些 VB 代码，它允许选择多个数据验证（列表下拉列表）选项，然后对于从列表中选择的每个下拉项目，它会在行尾输出选项，每列一个选项。

即：从下拉列表中选择 Apples、Bananas 和 Cherries 将输出 Apples |香蕉 | Cherries（其中 | 是列分隔符）位于第一个单元格为空的行的末尾。

我们的代码是：-

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler

Dim rngDV As Range
Dim iCol As Integer

If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
   If Target.Column = 3 Then
    If Target.Value = "" Then GoTo exitHandler
    If Target.Validation.Value = True Then
     iCol = Cells(Target.Row, Columns.Count).End(xlToLeft).Column + 1
     Cells(Target.Row, iCol).Value = Target.Value
   Else
     MsgBox "Invalid entry"
     Target.Activate
    End If
  End If
End If

exitHandler:
  Application.EnableEvents = True

End Sub

然而，我们希望在此 VB 代码中进行修改，而不是使用选定的数据验证填充行尾的单元格。我们想填充列标题与从下拉列表中选择的选项匹配的列下的单元格。

即：在下拉列表中选择的苹果将填充该行上标有“苹果”的列下的单元格。在下拉列表中选择的樱桃将填充该行上标有“樱桃”的列下的单元格。理想情况下，通过填充，我们会为该单元格着色或在其中放置一个 X，而不是重复所选项目的名称。

如果有人能建议我们在上面的代码中需要修改什么，将不胜感激。

Answer 1

我已按照您的要求修改了您的代码，它遍历列标题以找到正确的列，然后更改相应单元格的背景颜色。
更新：添加了一项检查以防止无限循环。

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo exitHandler

Dim rngDV As Range
Dim iCol As Integer, iColumnHeaderRow As Integer
iColumnHeaderRow = 3 'change this if header row changes

If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Not Intersect(Target, rngDV) Is Nothing Then
    Application.EnableEvents = False
    If Target.Column = 3 Then
        If Target.Value = "" Then GoTo exitHandler
        If Target.Validation.Value = True Then
            'iterate through column headers to find the matching column
            iCol = (Target.Column + 1)
            Do Until Cells(iColumnHeaderRow, iCol).Value = Target.Value
                iCol = iCol + 1
                'if we've hit a blank cell in the header row, exit 
                '(also to prevent an infinite loop here)
                If Cells(iColumnHeaderRow, iCol).Value = "" Then GoTo exitHandler
            Loop

            'set fill color of appropriate cell
            With Cells(Target.Row, iCol).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent6
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End With
        Else
            MsgBox "Invalid entry"
            Target.Activate
        End If
    End If
End If

exitHandler:
    Application.EnableEvents = True
End Sub

Answer 2

替换

Cells(Target.Row, iCol).Value = Target.Value

为

Cells(Target.Row, Range(Target.Value).Column).Value = "X"

注意：只有在您命名标题单元格时它才会起作用。例如，Range("Banana") 将引用您命名为“香蕉”的单元格。

要命名，请使用屏幕左上角的文本框。该文本框最初只包含单元格坐标，例如“A1”、“B2”等。单击您要命名的标题单元格，转到此文本框并输入“香蕉”或任何其他与您的下拉值匹配的名称。 用所有下拉值命名所有标题（缺少一个会导致错误）。

（你可以放弃 iCol 计算）