用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 Explicit
Private Sub cmdSave_Click()'非空验证If txtDate.Value = "" Or txtUserName.Value = "" Or txtUserCarNo.Value = "" _Or txtUserTel.Value = "" Or txtUserCarType.Value = "" ThenMsgBox "信息录入不完整，请补充完整后再保存！", vbCritical, "录入错误"txtUserName.SetFocusExit SubEnd If'车牌号去重验证Dim carID As String:        carID = txtUserCarNo.TextDim REPEATED As Boolean:    REPEATED = FalseDim cell As RangeFor Each cell In Sheet1.Columns("B:B").CellsIf cell.Value = carID ThenREPEATED = TrueExit ForEnd IfNext'未通过验证If REPEATED ThenMsgBox "您当前录入车牌号[" + carID + "]已被其他用户录入，请重新输入！", vbCritical, "车牌号重复"REPEATED = FalsetxtUserCarNo.SetFocustxtUserCarNo.SelStart = 0txtUserCarNo.SelLength = Len(carID)Exit SubEnd If'通过验证Application.ScreenUpdating = FalseSheet1.ActivateDim newRow As IntegernewRow = Sheet1.Range("A65536").End(xlUp).Row + 1Cells(newRow, 1).Value = txtDate.TextCells(newRow, 2).Value = txtUserCarNo.ValueCells(newRow, 3).Value = txtUserName.ValueCells(newRow, 4).Value = txtUserTel.ValueCells(newRow, 5).Value = txtUserCarType.ValueMsgBox "用户信息保存成功，单击【确定】继续！", vbInformation, "操作成功"txtUserCarNo.Value = ""txtUserName.Value = ""txtUserTel.Value = ""txtUserCarType.Value = ""Application.ScreenUpdating = True
End SubPrivate Sub cmdBack_Click()fmInput.HideSheet2.Activate
End SubPrivate Sub UserForm_Initialize()txtDate.Text = Format(Date, "yyyy/m/d")txtDate.Enabled = FalsetxtUserCarNo.Value = ""txtUserName.Value = ""txtUserTel.Value = ""txtUserCarType.Value = ""
End Sub

2、主窗体fmMain代码：

Private Sub cmdAddUserInfo_Click()Sheet1.ActivatefmMain.HidefmInput.Show
End SubPrivate Sub cmdQuery_Click()Sheet3.ActivatefmMain.HidefmQuery.Show
End Sub

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

Private Sub cmdQuery_Click()'非空验证If txtTargetCarID.Value = "" ThenMsgBox "要查询的车牌号错误或为空值", vbCritical, "输入错误"txtTargetCarID.SetFocusExit SubEnd IfApplication.ScreenUpdating = FalseSheet1.Activate'获取数据源区域和查询条件Dim carID As String:    carID = txtTargetCarID.TextDim lastRow As Integer: lastRow = Range("A65536").End(xlUp).RowSet sourceArea = Range(Cells(2, 1), Cells(lastRow, 5))'获取匹配记录总数Dim cell As RangeDim resultCount As IntegerFor Each cell In Sheet1.Range("B2:B" & lastRow)If cell.Value = carID ThenresultCount = resultCount + 1End IfNext'无记录则退出查询Dim info As StringIf resultCount = 0 Theninfo = "操作失败！" & vbCrLf & "没有找到车牌号为[ " & carID & " ]的用户信息，请核对车牌号后重试！"MsgBox info, vbCritical, "查询结果"txtTargetCarID.SetFocustxtTargetCarID.SelStart = 0txtTargetCarID.SelLength = Len(carID)Exit SubEnd If'有记录则循环输出查询结果Dim resultArea()ReDim resultArea(1 To resultCount, 1 To 5)Dim sourceRow As IntegerDim resultRow As IntegerFor sourceRow = 1 To sourceArea.Rows.CountIf sourceArea.Item(sourceRow, 2).Value = carID ThenresultRow = resultRow + 1For i = 1 To 5resultArea(resultRow, i) = sourceArea(sourceRow, i)Next ii = 0End IfNextSheet3.ActivateRange("A2:E65536").ClearContentsRange("A2:E5").Resize(resultCount) = resultAreainfo = "操作成功！" & vbCrLf & "共查询到" & resultCount & "条车牌号为[" & carID & "]的用户信息！"MsgBox info, vbInformation, "查询结果"txtTargetCarID.Text = ""txtTargetCarID.SetFocusApplication.ScreenUpdating = TrueEnd SubPrivate Sub cmdCancel_Click()fmQuery.HideSheet2.Activate
End Sub

运行结果：

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

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

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

（4）未查询到结果时：

要点小结

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

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

        txtUserCarNo.SetFocustxtUserCarNo.SelStart = 0txtUserCarNo.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)