Question

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

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

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

Answer 1

替代

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

代表

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

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

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

（你可以放弃iCol计算）

Answer 2

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

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

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

2 个答案: