扩展VB代码以在列名与数据验证匹配时填充Excel单元格

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

即：从下拉列表中选择苹果、香蕉和樱桃将输出苹果|香蕉|樱桃，其中|是第一个单元格为空的行末尾的列分隔符

我们的代码是：-

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代码中修改的是，不是用选定的数据验证填充行末尾的单元格。我们希望填充列标题与从下拉列表中选择的选项匹配的列下的单元格

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

如果有人能就我们需要在上述代码中修改的内容提出建议，我们将不胜感激。

替换

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

为了

注意：只有在命名标题单元格时，它才会起作用。例如，RangeBananer将引用您命名为Banana的单元格

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

---

您可以放弃iCol计算

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

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

---

你可以发布一个样本文件吗？我如何发布一个样本文件？我应该上传到Dropbox或类似的网站，并为你提供一个链接吗？是的，Dropbox很好。给你Brett。谢谢你看。如果在“排序”工作表上查看代码，您将看到VBA代码。您将看到C列包含数据验证，我可以在其中选择多个选项，在此示例中，基于此标准，我希望自动填充/着色相应的D-M列，尽管这里最终会有许多列。与当前一样，它会将选定的每个选项添加到下一个可用的空闲列AI中，然后每个列添加一个选项。谢谢现在我已经删除了上面的链接文件，因为我将其保存为.xls，所以我认为它没有包含代码。谢谢你的回答Daniel，这确实符合我的要求，非常感谢。纯粹基于另一个答案不要求我们使用相同名称的标题单元格这一事实，我会接受另一个答案为正确答案，因为这将更容易让这个问题的未来观众看到，而不会从你的答案中去掉任何“正确性”。再次感谢，谢谢你的回答，罗斯。这是完美的，完全符合我们的需要。尽管有两个答案都达到了我们想要的效果，但我还是将这一个标记为正确答案，因为它是更完整的代码，实现时需要更少的手动更改。再次感谢@杰夫杰克逊谢谢你，我很高兴能帮上忙。我只是更新了代码以防止潜在的错误，所以如果验证的条目与列标题不匹配。这不是投诉，不可能。但在Excel中使用代码时，始终考虑使用单元格名称。这使您可以移动列，而不用担心由于列/行号错误而导致的代码修复问题。@Daniel我同意，为了使其更具可扩展性，我将列标题全部放在一个命名范围内，即类别，并将该命名范围用于验证和循环中。通过这种方式，您也可以使用for循环在有限列表中进行迭代，从而无需进行测试以防止出现SO。然后，要向系统添加一个类别，只需插入一列并更新命名范围，无需调整代码。

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