用户表单包含需要自动完成公共值的单元格
User form has cells that need autocomplete for common values
我需要一个可以将值自动填充到单元格中的列表。通过设置表单的方式，我无法在底部列出和隐藏它们，因为评论单元格直到最后都是空的。
有没有办法在一个单元格中创建一个动态列表，使自动完成功能在相邻单元格中起作用？
一个单元格示例是名称。如果有人输入他们的名字并且在它应该自动完成之前已经输入了。如果是新名字，应该存起来留着下次使用。
我制作了一个宏来执行此操作，并在列中的所有空单元格中放置空格，使它们成为 "not empty"。不幸的是，该表格将包含尚未填写的内容，从而创建一个空单元格。
Sub WhiteRabbit()
'
'Macro WhiteRabbit
'
'Turn off screen updating and unprotect worksheet
Application.ScreenUpdating = False
Sheets("Entry Form").Select
ActiveSheet.Unprotect
'**********++++++++++============BEGIN GRABBING INFO============++++++++++**********
'COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B
'----------------COLUMN B Grab info----------------
Sheets("Entry Form").Select
Range("B7").Select '(Grab B7 Tech Name)
Selection.Copy
'Add to Auto List Column B
Sheets("Entry Form").Select
Range("B25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN B Grab info-------------
'============Remove Duplicates from Column B============
Range("B25").End(xlDown).Select
ActiveSheet.Range("B25", Range("B25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column B=========
'COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B
'COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D
'----------------COLUMN D Grab info----------------
Sheets("Entry Form").Select
Range("D13").Select '(Grab D13 UNIT)
Selection.Copy
'Add to Auto List Column D
Sheets("Entry Form").Select
Range("D25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN D Grab info-------------
'============Remove Duplicates from Column D============
Range("D25").End(xlDown).Select
ActiveSheet.Range("D25", Range("D25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column D=========
'COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D
'COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F
'----------------COLUMN F Grab info----------------
Sheets("Entry Form").Select
Range("F9").Select '(Grab F MODEL)
Selection.Copy
'Add to Auto List Column F
Sheets("Entry Form").Select
Range("F25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN F Grab info-------------
'============Remove Duplicates from Column F============
Range("F25").End(xlDown).Select
ActiveSheet.Range("F25", Range("F25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column D=========
'COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F
'**********++++++++++============END GRABBING INFO============++++++++++**********
'Reprotect Sheet
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False
Range("B7").Select
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
感谢@DisplayName 的回复。
我几乎没有使用 activex 组合框的经验。
我喜欢你的代码的去向。
你的代码很棒，我只需要它来处理 Tab 键。
如果我猜对了你想做什么，那么我会说你需要一个 "on-the-fly" ActiveX ComboBox
以下假设：
您的 sheet 中还没有任何 ActiveX 组合框
实际上，sheet
您的 sheet 代码窗格中没有 Worksheet_Change 事件处理
那你可以试试把下面的代码放到"Entry Form"sheet代码区（注释中有解释）
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If OLEObjects.Count > 0 Then 'check for any existing activeX combobox already in the sheet
With OLEObjects("myDD") ' if so, then reference the combobox you must have put through this code (see below)
If .Object.ListIndex = 0 Then ' if no elements selected in the combobox list
Range(.LinkedCell).ClearContents ' then clear the content of the cell you linked to the combobox through this code (see below)
Else 'otherwise
Range(.LinkedCell).Value = .Object.Value ' fill the content of the cell linked to the combobox with this latter selected value
ListUpdate Range(.LinkedCell) 'try and update the range from which combobox will be filled with
End If
.Delete ' delete the combobox and leave underneath cell visible
End With
End If
If target.Count <> 1 Then Exit Sub ' if selection is not a single cell then exit
If Intersect(target, Range("B7, D13, F9")) Is Nothing Then Exit Sub ' if selection is not one of the form entry cells then exit
With target 'reference selected cell
If IsEmpty(Cells(25, .Column).Value) Then Exit Sub ' if no values available fot the current entry cell then exit sub
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) ' add and reference a new ActiveX combobox
.Name = "myDD" 'name it as "myDD"
.ListFillRange = Range(Cells(25, target.Column), Cells(Rows.Count, target.Column).End(xlUp)).Address ' fill its range with already available values
.LinkedCell = target.Address ' link it to the selected cell
End With
End With
End Sub
Sub ListUpdate(target As Range)
If IsEmpty(Cells(25, target.Column).Value) Then Exit Sub ' if no values available fot the current entry cell then exit sub
With Range(Cells(25, target.Column), Cells(Rows.Count, target.Column).End(xlUp)) ' reference values already available
If .Find(what:=target.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then .Offset(.Rows.Count).Resize(1).Value = target.Value ' if new entered value not in the referenced values range already, then add it at the bottom of the list
End With
End Sub
我需要一个可以将值自动填充到单元格中的列表。通过设置表单的方式，我无法在底部列出和隐藏它们，因为评论单元格直到最后都是空的。
有没有办法在一个单元格中创建一个动态列表，使自动完成功能在相邻单元格中起作用？
一个单元格示例是名称。如果有人输入他们的名字并且在它应该自动完成之前已经输入了。如果是新名字，应该存起来留着下次使用。
我制作了一个宏来执行此操作，并在列中的所有空单元格中放置空格，使它们成为 "not empty"。不幸的是，该表格将包含尚未填写的内容，从而创建一个空单元格。
Sub WhiteRabbit()
'
'Macro WhiteRabbit
'
'Turn off screen updating and unprotect worksheet
Application.ScreenUpdating = False
Sheets("Entry Form").Select
ActiveSheet.Unprotect
'**********++++++++++============BEGIN GRABBING INFO============++++++++++**********
'COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B
'----------------COLUMN B Grab info----------------
Sheets("Entry Form").Select
Range("B7").Select '(Grab B7 Tech Name)
Selection.Copy
'Add to Auto List Column B
Sheets("Entry Form").Select
Range("B25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN B Grab info-------------
'============Remove Duplicates from Column B============
Range("B25").End(xlDown).Select
ActiveSheet.Range("B25", Range("B25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column B=========
'COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B COLUMN B
'COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D
'----------------COLUMN D Grab info----------------
Sheets("Entry Form").Select
Range("D13").Select '(Grab D13 UNIT)
Selection.Copy
'Add to Auto List Column D
Sheets("Entry Form").Select
Range("D25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN D Grab info-------------
'============Remove Duplicates from Column D============
Range("D25").End(xlDown).Select
ActiveSheet.Range("D25", Range("D25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column D=========
'COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D COLUMN D
'COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F
'----------------COLUMN F Grab info----------------
Sheets("Entry Form").Select
Range("F9").Select '(Grab F MODEL)
Selection.Copy
'Add to Auto List Column F
Sheets("Entry Form").Select
Range("F25").Select
Selection.End(xlDown).Select 'Go to last item
ActiveCell.Offset(1, 0).Range("A1").Select 'then one more to the next blank spot
'Paste value with invisible formatting
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Range("A1").Select
'Selection.NumberFormat = ";;;"
'----------------END COLUMN F Grab info-------------
'============Remove Duplicates from Column F============
Range("F25").End(xlDown).Select
ActiveSheet.Range("F25", Range("F25").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
'Add color back to Any that had it removed
Range(Selection, Selection.End(xlUp)).Select
'Range(Selection, Selection.End(xlUp)).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Selection.NumberFormat = ";;;"
'============End Remove Duplicates from Column D=========
'COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F COLUMN F
'**********++++++++++============END GRABBING INFO============++++++++++**********
'Reprotect Sheet
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False
Range("B7").Select
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
感谢@DisplayName 的回复。
我几乎没有使用 activex 组合框的经验。
我喜欢你的代码的去向。
你的代码很棒，我只需要它来处理 Tab 键。
如果我猜对了你想做什么，那么我会说你需要一个 "on-the-fly" ActiveX ComboBox
以下假设：
您的 sheet 中还没有任何 ActiveX 组合框
实际上，sheet
中不能有任何 ActiveX 控件或任何链接或嵌入的 OLE 对象
您的 sheet 代码窗格中没有
Worksheet_Change事件处理
那你可以试试把下面的代码放到"Entry Form"sheet代码区（注释中有解释）
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If OLEObjects.Count > 0 Then 'check for any existing activeX combobox already in the sheet
With OLEObjects("myDD") ' if so, then reference the combobox you must have put through this code (see below)
If .Object.ListIndex = 0 Then ' if no elements selected in the combobox list
Range(.LinkedCell).ClearContents ' then clear the content of the cell you linked to the combobox through this code (see below)
Else 'otherwise
Range(.LinkedCell).Value = .Object.Value ' fill the content of the cell linked to the combobox with this latter selected value
ListUpdate Range(.LinkedCell) 'try and update the range from which combobox will be filled with
End If
.Delete ' delete the combobox and leave underneath cell visible
End With
End If
If target.Count <> 1 Then Exit Sub ' if selection is not a single cell then exit
If Intersect(target, Range("B7, D13, F9")) Is Nothing Then Exit Sub ' if selection is not one of the form entry cells then exit
With target 'reference selected cell
If IsEmpty(Cells(25, .Column).Value) Then Exit Sub ' if no values available fot the current entry cell then exit sub
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) ' add and reference a new ActiveX combobox
.Name = "myDD" 'name it as "myDD"
.ListFillRange = Range(Cells(25, target.Column), Cells(Rows.Count, target.Column).End(xlUp)).Address ' fill its range with already available values
.LinkedCell = target.Address ' link it to the selected cell
End With
End With
End Sub
Sub ListUpdate(target As Range)
If IsEmpty(Cells(25, target.Column).Value) Then Exit Sub ' if no values available fot the current entry cell then exit sub
With Range(Cells(25, target.Column), Cells(Rows.Count, target.Column).End(xlUp)) ' reference values already available
If .Find(what:=target.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then .Offset(.Rows.Count).Resize(1).Value = target.Value ' if new entered value not in the referenced values range already, then add it at the bottom of the list
End With
End Sub