excel - Excel VBA - 将下拉选择中的值粘贴到列中
问题描述
For i = 1 To 20
If Target.Address = "$B$15" 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 & ", " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Worksheets("DropDowns").Cells(i + 7, 26).Value = Newvalue
Next i
我在代码的以下部分遇到问题:
Worksheets("DropDowns").Cells(i + 7, 26).Value = Newvalue
它上面的代码使列表下拉菜单具有多个选择,我试图将选择粘贴到一个单元格中,然后将新选择粘贴到它下面的单元格中,直到不再进行选择为止。但是,它目前正在做的是粘贴选择,然后将第二个选择粘贴到第一个上,然后将第三个粘贴到第二个等等。 下拉菜单选择,正在粘贴的内容,我想要粘贴的内容
解决方案
这应该做你想要的:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue, Newvalue, arr, rngList As Range
If Target.Address <> "$B$15" Then Exit Sub
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then Exit Sub
Set rngList = Worksheets("DropDowns").Cells(8, 26)
If Len(Target.Value) = 0 Then
rngList.Resize(20, 1).ClearContents
Exit Sub
End If
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 & ", " & Newvalue
Else
Target.Value = Oldvalue
End If
End If
Application.EnableEvents = True
'update the list of values
With rngList
.Resize(20, 1).ClearContents
arr = Split(Replace(Target.Value, " ", ""), ",") 'remove spaces before splitting
.Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
End With
End Sub
仅供参考,最好不要:
将多个语句放在一行上 - 它会很快变得混乱,尤其是在If
块内。
推荐阅读
- python - Python 无法长时间调度
- graphql - 如何过滤分配给 GraphQL 中别名的值?
- algorithm - 当除数尾数全为零时的浮点算法 - 比如在 2.0 in 的情况下 - IEEE -754
- r - 如何创建基于同一行中另一列的值命名的新列?
- konvajs - 通过从 Konvajs 的空白区域拖动来拖动变压器的最佳方法是什么?
- c# - .Net Core 3.1 身份中具有角色的用户列表
- fatal-error - 当我在 django 3 中使用“git push heroku master”时出现致命错误,“heroku open”出现“应用程序错误”
- flutter - 显示返回的 JSON
- performance - Openlayers 6.3.1 - 渲染 tilelayers
- javascript - 几次验证后无法将文档保存到猫鼬集合