用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 = "" 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 = True
End Sub

Private Sub cmdBack_Click()
    fmInput.Hide
    Sheet2.Activate
End Sub

Private 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.Show
End Sub

Private Sub cmdQuery_Click()
    Sheet3.Activate
    fmMain.Hide
    fmQuery.Show
End 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 Sub

Private Sub cmdCancel_Click()
    fmQuery.Hide
    Sheet2.Activate
End 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)