No.1

Excel操作过程当中，有时我们需要把某一个字段的数据进行列表处理，也就要做成列表，但是又不想数据重复，这就需要把Excel 数据表中重复的数据进行筛选。

本节就介绍一下，如何利用VBA代码来进行数据列表筛选，然后将筛选出的数据制作成数据验证列表。

下图为本节示例，将左侧日期列表中有重要项的筛选过滤掉，然后在右侧列出，制作成一个数据验证下拉列表，红色日期就是最终完成结果单元格。

做这个的目的就是在一列中，把重复项目选出来，为下拉列表进行填充，以供使用下拉选择。

在一些选择框中，会经常用到，所以这个取重复项目还是很有用的。

No.2

实例代码

本例中，代码包括三个部分：

1. 主调用过程 CommandButton1_Click
2. 新建数据验证列表函数 addNewValidation()
3. 返回数组地址 getCellsArr()

接下来，分别代码如下：

1、主调用过程

Private Sub CommandButton1_Click()
Dim R As range
Set R = ActiveSheet.range("B3")
Call addNewValidation(R, getCellsArr(ActiveSheet, "B"))
End Sub

这个代码放到按钮单击事件里，当然可以放到任何事件当中，主要看程序的需要。

主过程调用的是函数addNewValidation()函数，其有两个参数，要设置正确，一个是日期列工作表，另一个是工作表列名。

2、新建数据验证列表函数 addNewValidation()

Sub addNewValidation(RangeAddr As range, cellsAddress As String)
'新建数据验证列表
  With RangeAddr.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=" & cellsAddress
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End Sub

addNewValidation()函数实现新建一个数据验证列，两个参数，RangeAddr为新建验证的单元格，cellsAddress为验证列表的地址，这个参数我们使用另一个函数返回。

3、返回筛选后日期数据表地址

Function getCellsArr(s As Worksheet, cell As String) As String '返回地址
On Error Resume Next
    Dim w As Worksheet
    Set w = ActiveSheet
    Dim R As range, Rowi As Long
    w.UsedRange.Rows.Hidden = False
    Rowi = w.range(cell & w.Cells.Rows.Count).End(xlUp).Row
    Set R = w.range(cell & "4:" & cell & Rowi)    
    Dim xR As range, xRArr() As Date, xi As Integer, xA As Variant, isEq As Boolean
    xi = 0
    isEq = False
    ReDim xRArr(xi)
    For Each xR In R
        For Each xA In xRArr
            If xA = xR.Value Then
                isEq = True
                Exit For
            End If
        Next xA
        If Not isEq Then
            ReDim Preserve xRArr(xi)
            xRArr(xi) = xR.Value
            xi = xi + 1
        End If
        isEq = False
    Next xR
    s.range("C:C").ClearContents
    s.range("C4").Value = "搜索日期"
    Set R = s.range("C5:C" & UBound(xRArr) + 5)
    R.Value = Application.WorksheetFunction.Transpose(xRArr)
    R.Interior.Color = QBColor(11)
    Set s = Nothing
    Set w = Nothing
    getCellsArr = R.Address
    Set R = Nothing
    Erase xRArr
End Function

本函数在使用过程中需要一些微小改动，由于不同的数据表保存位置不同所以函数中的一些处理结果也不会相同。如果是一张空表，也就不用更改，可以直接使用。

看上去这么多代码，其实实现的功能最终并不会显得十分复杂，甚至根本感觉不到发生了什么变化，但就是这些微小的变化，可以使我们的工作更加便捷。

欢迎关注、收藏

---END---