VBA代码，使每个值从excel单元格中相邻单元格中的多选相关下拉列表中选择

Question

我在excel中创建了一个多选相关下拉列表。当我从多选列表中选择时，我可以在新行中的单个单元格中拥有每个选定的值。然而，我想把每个选择放在一个相邻的单独单元格中，而不是把值塞进一个单元格中。例如，当我从下拉列表中选择"男性"one_answers"女性"时，我希望"男性"出现在下面的第一个单元格中，"女性"出现在下一个单元格中。我只想将代码应用于具有多选下拉列表的一列。有人有那个密码吗？

我目前使用的代码如下：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Not Intersect(Target, Range("L9")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & vbNewLine & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub

Answer 1

请测试下一个更新的事件：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String, Newvalue As String, lastRM As Long, mtch
'Application.EnableEvents = True 'useless code line
On Error GoTo Exitsub
If Not Intersect(Target, Range("L9")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else
If Target.Value = "" Then
Me.Range(Target.Offset(, 1), Target.Offset(, 1).End(xlDown)).ClearContents
GoTo Exitsub
Else
Application.EnableEvents = False
lastRM = Target.Offset(, 1).End(xlDown).row
If lastRM = Me.rows.count Then
If Target.Offset(, 1).Value <> "" Then
If Target.Offset(, 1).Value <> Target.Value Then
Target.Offset(1, 1).Value = Target.Value
End If
Else
Target.Offset(, 1) = Target.Value
End If
Else
mtch = Application.match(Target.Value, Me.Range(Target.Offset(, 1), Target.Offset(, 1).End(xlDown)), 0)
If IsError(mtch) Then
Target.Offset(lastRM - Target.row + 1, 1) = Target.Value
End If
End If
End If
End If
End If
'Application.EnableEvents = True 'useless code line
Exitsub:
Application.EnableEvents = True
End Sub

编辑：

请测试下一个版本，它将完成您在上一条评论中所要求的操作(返回L:L列，从L9开始，包括L9(：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String, Newvalue As String, lastRM As Long, mtch
Application.Calculation = xlCalculationManual
On Error GoTo Exitsub
If Not Intersect(Target, Range("L9")) Is Nothing Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else
Application.EnableEvents = False
If Target.Value = "" Then
Me.Range(Target.Offset(1), Target.Offset(1).End(xlDown)).ClearContents
GoTo Exitsub
Else
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
lastRM = Target.End(xlDown).row
If lastRM = Me.rows.count Then
If Oldvalue <> "" Then
Target.Offset(1).Value = Newvalue
End If
Else
mtch = Application.match(Newvalue, Me.Range(Target, Target.End(xlDown)), 0)
If IsError(mtch) Then
Target.Offset(lastRM - Target.row + 1) = Newvalue
End If
End If
If Oldvalue <> "" Then
Target.Value = Oldvalue
Else
Target.Value = Newvalue
End If
End If
End If
End If
Application.Calculation = xlCalculationAutomatic
Exitsub:
Application.EnableEvents = True
End Sub

请在测试后发送一些反馈。