用Excel VBA代码实现去重录入某字段内容

功能描述

图1 信息录入表单示意图

图2 用于录入信息的自定义窗体示意图

如图所示，在样表中用自定义窗体录入信息，要求：

1、日期自动设为当前日期，不用手动录入；

2、车牌号不能重复录入（之前重复的不作考虑），否则停止运行，并弹出消息；

要点分析

1、实现功能1要点

　　禁用日期文本框，当前日期用Format(Date, "yyyy/m/d")获取

2、实现功能2要点

（1）查找车牌号：用for-each遍历，若找到，则转至（2）；否则转至（4）

（2）中断循环，给出提示：用MsgBox；

（3）再选中该车牌号文本：用text.SelStart和text.SelLength；转到（6）

-------------------

（4）在新的一行录入信息：新行标用Range("A65536").End(xlUp).Row+1

（5）录入文本框内容清理；

（6）退出录入过程；

其他组件

1、主窗体fmMain

在打开Excel或选中Sheet2时显示该主页面：

2、查询窗体fmQuery

查询车牌号，结果列在Sheet3中：

完整代码

1、录入窗体fmImput代码：

Option ExplicitPrivate Sub cmdSave_Click()    '非空验证    If txtDate.Value = "" Or txtUserName.Value = "" Or txtUserCarNo.Value = "" _    Or txtUserTel.Value = "" Or txtUserCarType.Value = "" Then        MsgBox "信息录入不完整，请补充完整后再保存！", vbCritical, "录入错误"        txtUserName.SetFocus        Exit Sub    End If        '车牌号去重验证    Dim carID As String:        carID = txtUserCarNo.Text    Dim REPEATED As Boolean:    REPEATED = False        Dim cell As Range    For Each cell In Sheet1.Columns("B:B").Cells        If cell.Value = carID Then            REPEATED = True            Exit For        End If    Next        '未通过验证    If REPEATED Then        MsgBox "您当前录入车牌号[" + carID + "]已被其他用户录入，请重新输入！", vbCritical, "车牌号重复"        REPEATED = False        txtUserCarNo.SetFocus        txtUserCarNo.SelStart = 0        txtUserCarNo.SelLength = Len(carID)        Exit Sub    End If    '通过验证    Application.ScreenUpdating = False                Sheet1.Activate        Dim newRow As Integer        newRow = Sheet1.Range("A65536").End(xlUp).Row + 1                Cells(newRow, 1).Value = txtDate.Text        Cells(newRow, 2).Value = txtUserCarNo.Value        Cells(newRow, 3).Value = txtUserName.Value        Cells(newRow, 4).Value = txtUserTel.Value        Cells(newRow, 5).Value = txtUserCarType.Value                MsgBox "用户信息保存成功，单击【确定】继续！", vbInformation, "操作成功"                txtUserCarNo.Value = ""        txtUserName.Value = ""        txtUserTel.Value = ""        txtUserCarType.Value = ""        Application.ScreenUpdating = TrueEnd SubPrivate Sub cmdBack_Click()    fmInput.Hide    Sheet2.ActivateEnd SubPrivate Sub UserForm_Initialize()    txtDate.Text = Format(Date, "yyyy/m/d")    txtDate.Enabled = False    txtUserCarNo.Value = ""    txtUserName.Value = ""    txtUserTel.Value = ""    txtUserCarType.Value = ""End Sub

2、主窗体fmMain代码：

Private Sub cmdAddUserInfo_Click()    Sheet1.Activate    fmMain.Hide    fmInput.ShowEnd SubPrivate Sub cmdQuery_Click()    Sheet3.Activate    fmMain.Hide    fmQuery.ShowEnd Sub

3、查询车牌窗体fmQuery代码：

Private Sub cmdQuery_Click()    '非空验证    If txtTargetCarID.Value = "" Then        MsgBox "要查询的车牌号错误或为空值", vbCritical, "输入错误"        txtTargetCarID.SetFocus        Exit Sub    End If        Application.ScreenUpdating = False        Sheet1.Activate                '获取数据源区域和查询条件        Dim carID As String:    carID = txtTargetCarID.Text        Dim lastRow As Integer: lastRow = Range("A65536").End(xlUp).Row        Set sourceArea = Range(Cells(2, 1), Cells(lastRow, 5))                '获取匹配记录总数        Dim cell As Range        Dim resultCount As Integer        For Each cell In Sheet1.Range("B2:B" & lastRow)            If cell.Value = carID Then                resultCount = resultCount + 1            End If        Next                '无记录则退出查询        Dim info As String        If resultCount = 0 Then            info = "操作失败！" & vbCrLf & "没有找到车牌号为[ " & carID & " ]的用户信息，请核对车牌号后重试！"            MsgBox info, vbCritical, "查询结果"            txtTargetCarID.SetFocus            txtTargetCarID.SelStart = 0            txtTargetCarID.SelLength = Len(carID)            Exit Sub        End If                '有记录则循环输出查询结果        Dim resultArea()        ReDim resultArea(1 To resultCount, 1 To 5)        Dim sourceRow As Integer        Dim resultRow As Integer        For sourceRow = 1 To sourceArea.Rows.Count            If sourceArea.Item(sourceRow, 2).Value = carID Then                resultRow = resultRow + 1                For i = 1 To 5                    resultArea(resultRow, i) = sourceArea(sourceRow, i)                Next i                i = 0            End If        Next                Sheet3.Activate        Range("A2:E65536").ClearContents        Range("A2:E5").Resize(resultCount) = resultArea                info = "操作成功！" & vbCrLf & "共查询到" & resultCount & "条车牌号为[" & carID & "]的用户信息！"        MsgBox info, vbInformation, "查询结果"                        txtTargetCarID.Text = ""        txtTargetCarID.SetFocus        Application.ScreenUpdating = True    End SubPrivate Sub cmdCancel_Click()    fmQuery.Hide    Sheet2.ActivateEnd Sub

运行结果：

（1）录入重复车牌号时：

（2）录入不重复车牌时：

（3）查询到已有车牌时：（多条记录）

（4）未查询到结果时：

要点小结

1、命名统一采用“控件简称+描述性名称”（如txtDate、cmdSave等）的方式，便于后期维护与更新；

2、选中文本框中文本的方法：

        txtUserCarNo.SetFocus        txtUserCarNo.SelStart = 0        txtUserCarNo.SelLength = Len(carID)

3、获取工作表中整列区域：

Sheet1.Columns("B:B").Cells

4、获取当前区域的最后一行行标：

Sheet1.Range("A65536").End(xlUp).Row

5、格式化当前时间：

Format(Date, "yyyy/m/d")

6、初始化窗体的控件事件不能使用自定义名称：

正确：

Private Sub UserForm_Initialize()    ...End Sub

错误：

Private Sub fmInput_Initialize()    ...End Sub

7、命令按钮快捷键设置：用Accelerator属性

8、使用动态数组节约内存资源：

        Dim resultArea()        ReDim resultArea(1 To resultCount, 1 To 5)