用户表单包含需要为常用值自动完成的单元格

Posted 2021-05-02

我需要一个列表，将值自动填充到单元格中。通过表单的设置方式，我无法在底部列出并隐藏它们，因为注释单元格在结尾之前是空的。

有没有办法在单元格内制作动态列表，使自动完成在相邻单元格内工作？

一个单元格的例子是Name。如果有人输入了他们的名字并且在输入之前它已经自动完成了。如果是新名称，则应将其存储下次。

我做了一个宏来做这个，并在列中的所有空单元格中放置空格，使它们“不为空”。不幸的是，表单中会有一些未填充的东西会创建一个空单元格。

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组合框的经验。 我喜欢你的代码在哪里。

你的代码很棒，我只需要它就可以使用tabbing。

答案

如果我正确地猜测你想做什么，那么我会说你需要一个“即时”的ActiveX ComboBox

以下假设：

• 您的工作表中没有任何ActiveX组合框 实际上，您必须在工作表中没有任何ActiveX控件或任何链接或嵌入的OLE对象
• 您没有在工作表代码窗格中处理Worksheet_Change事件

那么您可以尝试将以下代码放在“条目表单”表格代码窗格中（注释中的说明）

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