原代码是用窗格列出匹配项，手动选择自动填充的，我现在想要修改下。
求助大佬修改下代码，不胜感激！
如果没有选择候选窗格的内容，就清空输入值。
如果选择了候选窗格的内容，就把该内容填充到D列最后一个有内容的单元格的下一格位置，并且把该内容最后两个字的拼音首字母填充到E列对应位置。
填充内容后，检查D列的数值是否有超过6个字符相同，就弹出窗口列出有多少数值是超过6字符相同的。
网盘上有附件，里面有详细说明。求大佬下来看看修改下
链接: 百度网盘 提取码: fuhe
以下是代码：
Dim myCel As Range
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ar, br(), i&, j&, strTarget$
If Target.Count > 1 Then Exit Sub
If Target.Column <> 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
ar = Range("d1", Cells(Rows.Count, "e").End(3))
strTarget = Target.Value
For i = 1 To UBound(ar)
If InStr(ar(i, 2), strTarget) Then
r = r + 1
ReDim Preserve br(1 To r)
br(r) = ar(i, 1)
End If
If InStr(ar(i, 1), strTarget) Then
r = r + 1
ReDim Preserve br(1 To r)
br(r) = ar(i, 1)
End If
Next i
Set myCel = Target
If r = 0 Then
MsgBox "未找到"
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
Exit Sub
End If
If r = 1 Then
Application.EnableEvents = False
myCel = br(r)
Application.EnableEvents = True
Exit Sub
End If
With Application.CommandBars.Add(Name:="myCell", Position:=5)
For i = 1 To UBound(br)
With .Controls.Add(Type:=1)
.Caption = br(i)
.OnAction = "Sheet1.myCellAction"
End With
Next
.ShowPopup
.Delete
End With
Set myCel = Nothing
End Sub
Sub myCellAction()
Application.EnableEvents = False
myCel = Application.CommandBars.ActionControl.Caption
Application.EnableEvents = True
End Sub

帮顶

Dim myCel As Range
Dim selectedValue As String
' 当工作表中的任何单元格发生变化时触发
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ar, br(), i&, j&, strTarget$
Dim r As Long
' 如果更改的单元格数量大于1，则退出子程序
If Target.Count > 1 Then Exit Sub
' 如果更改的单元格不在第一列，则退出子程序
If Target.Column <> 1 Then Exit Sub
' 如果更改的单元格为空，则退出子程序
If Target.Value = "" Then Exit Sub
' 读取D列到E列的所有数据
ar = Range("d1", Cells(Rows.Count, "e").End(3))
' 将目标单元格的值存储在strTarget中
strTarget = Target.Value
' 遍历范围内的每一行，查找包含目标值的单元格
For i = 1 To UBound(ar)
If InStr(ar(i, 2), strTarget) Then
r = r + 1
ReDim Preserve br(1 To r)
br(r) = ar(i, 1)
End If
If InStr(ar(i, 1), strTarget) Then
r = r + 1
ReDim Preserve br(1 To r)
br(r) = ar(i, 1)
End If
Next i
' 设置myCel为目标单元格
Set myCel = Target
' 如果没有找到匹配项，弹出消息框询问是否需要补充到D列
If r = 0 Then
If MsgBox("未找到匹配项，是否需要补充到D列？", vbYesNo) = vbYes Then
Call FillCells(Target.Value)
Else
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
Exit Sub
End If
' 如果找到一个匹配项，直接将目标单元格的值替换为匹配项
If r = 1 Then
Application.EnableEvents = False
myCel = br(r)
Application.EnableEvents = True
Exit Sub
End If
' 如果找到多个匹配项，创建一个弹出菜单，列出所有匹配项供用户选择
Dim cmdBar As CommandBar
Set cmdBar = Application.CommandBars.Add(Name:="myCell", Position:=msoBarPopup, Temporary:=True)
For i = 1 To UBound(br)
With cmdBar.Controls.Add(Type:=msoControlButton)
.Caption = br(i)
.OnAction = "Sheet1.myCellAction"
End With
Next
' 设置弹出菜单的位置
cmdBar.ShowPopup
cmdBar.Delete
Set myCel = Nothing
End Sub
' 当用户选择菜单项时，将目标单元格的值替换为所选项
Sub myCellAction()
Application.EnableEvents = False
selectedValue = Application.CommandBars.ActionControl.Caption
myCel.Value = selectedValue
Application.EnableEvents = True
End Sub
' 填充D列和E列的内容
Sub FillCells(value As String)
Dim lastRow As Long
Dim pinyin As String
' 填充到D列最后一个有内容的单元格的下一格位置
lastRow = Cells(Rows.Count, "D").End(xlUp).Row + 1
Cells(lastRow, "D").Value = value
' 获取最后两个字的拼音首字母
pinyin = GetPinyinInitials(Right(value, 2))
Cells(lastRow, "E").Value = pinyin
' 检查D列的内容是否有超过3个汉字相同
Call CheckDuplicates
End Sub
' 获取最后两个字的拼音首字母
Function GetPinyinInitials(text As String) As String
' 这里需要实现一个获取拼音首字母的函数
' 由于VBA不支持直接获取拼音，可以考虑使用外部库或自定义映射
' 这里只是一个示例，实际实现需要根据具体需求调整
Dim initials As String
initials = "示例" ' 替换为实际拼音首字母
GetPinyinInitials = initials
End Function
' 检查D列中是否有超过3个汉字相同的内容，并弹出消息框
Sub CheckDuplicates()
Dim dict As Object
Dim cell As Range
Dim count As Long
Dim msg As String
Dim key As Variant
' 创建一个字典对象
Set dict = CreateObject("Scripting.Dictionary")
' 遍历D列中的每个单元格
For Each cell In Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row)
' 如果单元格的值长度超过3个汉字
If Len(cell.Value) > 3 Then
' 提取前3个汉字
key = Left(cell.Value, 3)
' 如果字典中已存在该值，则计数加1
If dict.exists(key) Then
dict(key) = dict(key) + 1
Else
' 如果字典中不存在该值，则添加该值并将计数设为1
dict.Add key, 1
End If
End If
Next cell
' 初始化消息字符串
msg = ""
' 遍历字典中的每个键
For Each key In dict.keys
' 如果某个值的计数大于1，则将其添加到消息字符串中
If dict(key) > 1 Then
msg = msg & key & " 出现了 " & dict(key) & " 次" & vbCrLf
End If
Next key
' 如果有超过3个汉字相同的内容，弹出消息框
If msg <> "" Then
MsgBox "以下内容超过3个汉字相同：" & vbCrLf & msg
End If
End Sub