Excel应用实践12：在用户窗体中添加、查找和编辑数据记录
Excel应用实践12：在用户窗体中添加、查找和编辑数据记录
学习Excel技术，关注微信公众号：
excelperfect
在Excel中，我已经创建了一个输入数据的用户窗体，用于在工作记录工作表中添加新数据记录。最近，老板提出了新的需求，要通过该用户窗体能够编辑数据记录，增强其功能。
这是我们在使用Excel编程时经常会遇到的问题。虽说直接在工作表中添加数据没有什么不好的，但就是有很多人喜欢使用自已设计的界面输入数据，包括我自已。在设计好输入数据界面后，更进一步增强界面的功能，可以查找数据，对找到的数据进行编辑并将修改更新到工作表中。如下图1所示。
图1
用户窗体界面设计
存储数据的工作表如下图2所示。
图2
根据工作表数据结构，设计用户窗体如下图3所示。
图3
其中，用于导航的4个标签按钮放置在一个名为fraNavigate的框架控件中。
编写代码
通用代码
在标准模块中，输入下面的代码：
' API声明
#If VBA7 And Win64 Then
Public Declare PtrSafe Sub Sleep Lib"kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Public Declare Sub Sleep Lib"kernel32" (ByVal dwMilliseconds As Long)
#End If
' 常量声明
Public Const MOUSE_DOWN_SLEEP =250
' 全局变量声明
Public blnFormComplete AsBoolean
Public blnMouseDown As Boolean
Public strNotCompleted AsString
' 代表消息框信息的变量声明
Public intResponse As Integer
Public lngStyle As Long
Public strInput As String
Public strMsg As String
Public strTitle As String
'与工作表行数相关的变量声明
Public lngLastRow As Long
Public lngRow As Long
Public lngMatchRow As Long
'获取工作表中最后的数据行
Public Function LastRow( _
objWorkSheetFindLastRow As Worksheet, _
intColFindLastRow As Integer) As Long
With objWorkSheetFindLastRow
LastRow = .Cells(.Rows.Count, _
intColFindLastRow).End(xlUp).Row
End With
End Function
用户窗体模块代码
在用户窗体模块中，输入下面的代码：
'清空用户窗体中的数据
Private Sub ClearUserForm()
Me.txtProjectNumber = ""
Me.txtProjectName = ""
Me.cboAnalyst = ""
Me.cboClient = ""
Me.txtDueDate = ""
Me.txtPriority = ""
Me.cboNumberSamples = ""
End Sub
'添加记录
Private Sub cmdAddEdit_Click()
'添加记录
If Me.cmdAddEdit.Caption = "添加记录" Then
'检查所有的内容是否都已填写.
blnFormComplete = True
strNotCompleted = ""
If Me.txtProjectNumber = ""Then
blnFormComplete = False
strNotCompleted = "项目编号 :" & vbCrLf
End If
If Me.txtProjectName = ""Then
blnFormComplete = False
strNotCompleted = strNotCompleted& "项目名称 :" & vbCrLf
End If
If Me.cboAnalyst = "" Then
blnFormComplete = False
strNotCompleted = strNotCompleted& "分析人 :" & vbCrLf
End If
If Me.cboClient = "" Then
blnFormComplete = False
strNotCompleted = strNotCompleted& "客户 :" & vbCrLf
End If
If Me.txtDueDate = "" Then
blnFormComplete = False
strNotCompleted = strNotCompleted& "截止日期 :" & vbCrLf
End If
If Me.txtPriority = "" Then
blnFormComplete = False
strNotCompleted = strNotCompleted& "优先级 :" & vbCrLf
End If
'如果有内容没有填写
'则用信息框给用户显示相关信息
If blnFormComplete = False Then
strMsg = "下列内容还没有填写完成: " & vbCrLf &strNotCompleted
lngStyle = vbOKOnly + vbInformation
strTitle = "不能添加记录 - 未完成内容填写"
Beep
intResponse = MsgBox(strMsg,lngStyle, strTitle)
Exit Sub
End If
'查找工作表中最后一行之后的空行
lngLastRow = LastRow(wsProjectData, 1)+ 1
'将用户窗体数据输入到工作表
wsProjectData.Cells(lngLastRow,"A") = Me.txtProjectNumber
wsProjectData.Cells(lngLastRow,"B") = Me.txtProjectName
wsProjectData.Cells(lngLastRow,"C") = Me.cboAnalyst
wsProjectData.Cells(lngLastRow,"D") = Me.cboClient
wsProjectData.Cells(lngLastRow,"E") = Me.txtDueDate
wsProjectData.Cells(lngLastRow,"F") = Me.txtPriority
wsProjectData.Cells(lngLastRow,"G") = Me.cboNumberSamples
'用信息框给用户显示相关信息
strMsg = "已添加记录到" & wsProjectData.Name& " 行" & Str(lngLastRow)
lngStyle = vbOKOnly + vbInformation
strTitle = "记录已添加"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
'编辑记录
Else
strMsg = "编辑项目编号 : " & Me.txtProjectNumber& " ?"
lngStyle = vbYesNo + vbQuestion
strTitle = "编号记录 ?"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
If intResponse = vbNo Then Exit Sub
On Error GoTo ProjectNumberNoMatch
'查找到要编辑的项目编号所在单元格
lngMatchRow =Application.Match(Me.txtProjectNumber, wsProjectData.Columns("A"), 0)
On Error GoTo 0
'已找到要编辑的项目编号
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第" & Str(lngMatchRow) & " 行"
'更新记录
wsProjectData.Cells(lngMatchRow,"A") = Me.txtProjectNumber
wsProjectData.Cells(lngMatchRow,"B") = Me.txtProjectName
wsProjectData.Cells(lngMatchRow,"C") = Me.cboAnalyst
wsProjectData.Cells(lngMatchRow,"D") = Me.cboClient
wsProjectData.Cells(lngMatchRow,"E") = Me.txtDueDate
wsProjectData.Cells(lngMatchRow,"F") = Me.txtPriority
wsProjectData.Cells(lngMatchRow,"G") = Me.cboNumberSamples
'用找到的项目编号所在行数据填充用户窗体
PopulateUserForm lngMatchRow
'用信息框显示相应信息
strMsg = "项目编号 : " & Me.txtProjectNumber & " 已更新."
lngStyle = vbOKOnly + vbInformation
strTitle = "记录已更新"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
End If
Exit Sub
ProjectNumberNoMatch:
strMsg = "项目编号 " & Me.txtProjectNumber& " 没有找到."
lngStyle = vbOKOnly + vbInformation
strTitle = "没有找到项目编号"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
End Sub
Private SubcmdProjectNumberFind_Click()
lngMatchRow = 0
If Me.txtProjectNumber = "" Then
strMsg = "没有指要查找的项目编号."
lngStyle = vbOKOnly + vbInformation
strTitle = "没有指定项目编号"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
Exit Sub
End If
On Error GoTo ProjectNumberNoMatch
lngMatchRow =Application.Match(Me.txtProjectNumber, wsProjectData.Columns("A"), 0)
On Error GoTo 0
'找到了项目编号.
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第" & Str(lngMatchRow) & " 行"
lngRow = lngMatchRow
PopulateUserForm lngMatchRow
Exit Sub
ProjectNumberNoMatch:
strMsg = "项目编号 " & Me.txtProjectNumber& " 没有找到."
lngStyle = vbOKOnly + vbInformation
strTitle = "没有找到项目编号"
Beep
intResponse = MsgBox(strMsg, lngStyle,strTitle)
End Sub
'---------------------------
'设置导航按钮
'---------------------------
Private Sub lblFirst_Click()
lngRow = 2
PopulateUserForm lngRow
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第2行"
End Sub
Private Sub lblFirst_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblFirst.SpecialEffect =fmSpecialEffectSunken
End Sub
Private Sub lblFirst_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
RestoreBackColors
MouseMove "lblFirst"
End Sub
Private Sub lblFirst_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblFirst.SpecialEffect =fmSpecialEffectRaised
End Sub
Private Sub lblLast_Click()
lngRow = lngLastRow
PopulateUserForm lngRow
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的最后一行"
End Sub
Private Sub lblLast_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblLast.SpecialEffect =fmSpecialEffectSunken
End Sub
Private Sub lblLast_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
RestoreBackColors
MouseMove "lblLast"
End Sub
Private Sub lblLast_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblLast.SpecialEffect =fmSpecialEffectRaised
End Sub
Private Sub lblNext_MouseDown(ByValButton As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y AsSingle)
Me.lblNext.SpecialEffect =fmSpecialEffectSunken
MouseDownNext
End Sub
Private Sub lblNext_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
RestoreBackColors
MouseMove "lblNext"
End Sub
Private Sub lblNext_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblNext.SpecialEffect =fmSpecialEffectRaised
blnMouseDown = False
End Sub
Private Sub lblPrev_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblPrev.SpecialEffect =fmSpecialEffectSunken
MouseDownPrevious
End Sub
Private Sub lblPrev_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
RestoreBackColors
MouseMove "lblPrev"
End Sub
Private Sub lblPrev_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X AsSingle, ByVal Y As Single)
Me.lblPrev.SpecialEffect =fmSpecialEffectRaised
blnMouseDown = False
End Sub
Private Sub MouseDownNext()
blnMouseDown = True
Do While blnMouseDown = True
Select Case lngRow
Case lngLastRow
lngRow = lngLastRow
Case Else
lngRow = lngRow + 1
'到达最后一行
If lngRow >= lngLastRow ThenlngRow = lngLastRow
PopulateUserForm lngRow
End Select
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第 " & Trim(Str(lngRow)) & " 行"
Sleep MOUSE_DOWN_SLEEP
DoEvents
Loop
End Sub
Private Sub MouseDownPrevious()
blnMouseDown = True
Do While blnMouseDown = True
Select Case lngRow
Case 2
'数据行的首行
lngRow = 2
Case Else
lngRow = lngRow - 1
'到达首行
If lngRow <= 2 Then lngRow = 2
PopulateUserForm lngRow
End Select
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第 " & Trim(Str(lngRow)) & " 行"
Sleep MOUSE_DOWN_SLEEP
DoEvents
Loop
End Sub
Sub MouseMove(strControl AsString)
'鼠标经过控件时高亮显示该控件
Select Case strControl
'标签名导航
Case "lblFirst"
Me.lblFirst.BackColor = vbYellow
Case "lblLast"
Me.lblLast.BackColor = vbYellow
Case "lblNext"
Me.lblNext.BackColor = vbYellow
Case "lblPrev"
Me.lblPrev.BackColor = vbYellow
End Select
End Sub
'添加模式
Private Sub optAddMode_Click()
'将按钮文本修改为"添加记录"
Me.cmdAddEdit.Caption = "添加记录"
Me.cmdAddEdit.ControlTipText = "添加记录"
'使查找项目编号按钮不可见
Me.cmdProjectNumberFind.Visible = False
'使导航栏不可见
Me.fraNavigate.Visible = False
'使显示记录条数信息的标签不可见
Me.lblRecordNofTotal.Visible = False
'清除用户窗体中的数据
ClearUserForm
End Sub
'查找和编辑模式
Private SuboptSearchAndEditMode_Click()
'将按钮文本修改为"编辑记录"
Me.cmdAddEdit.Caption = "编辑记录"
Me.cmdAddEdit.ControlTipText = "编辑记录"
'使查找项目编号按钮可见
Me.cmdProjectNumberFind.Visible = True
'使导航栏可见
Me.fraNavigate.Visible = True
'使显示记录条数信息的标签可见
Me.lblRecordNofTotal.Visible = True
'显示工作表中第2行的数据
lngRow = 2
lngLastRow = LastRow(wsProjectData, 1)
PopulateUserForm 2
Me.lblRecordNofTotal = "在 " & Str(lngLastRow) &" 行中的第 " & Trim(Str(lngRow)) & " 行"
End Sub
'重置按钮标签颜色
Private Sub RestoreBackColors()
Me.lblFirst.BackColor = vbWhite
Me.lblNext.BackColor = vbWhite
Me.lblPrev.BackColor = vbWhite
Me.lblLast.BackColor = vbWhite
End Sub
'激活用户窗体时
Private Sub UserForm_Activate()
'填充组合框
With Me.cboAnalyst
.AddItem "Analyst 1"
.AddItem "Analyst 2"
.AddItem "Analyst 3"
.AddItem "Analyst 4"
End With
With Me.cboClient
.AddItem "Client 1"
.AddItem "Client 2"
.AddItem "Client 3"
.AddItem "Client 4"
End With
With Me.cboNumberSamples
.AddItem "Number Samples 1"
.AddItem "Number Samples 2"
.AddItem "Number Samples 3"
.AddItem "Number Samples 4"
End With
End Sub
'填充用户窗体中的控件
Public Sub PopulateUserForm(lngPopulateRow As Long)
Me.txtProjectNumber =wsProjectData.Cells(lngPopulateRow, "A")
Me.txtProjectName =wsProjectData.Cells(lngPopulateRow, "B")
Me.cboAnalyst =wsProjectData.Cells(lngPopulateRow, "C")
Me.cboClient =wsProjectData.Cells(lngPopulateRow, "D")
Me.txtDueDate =wsProjectData.Cells(lngPopulateRow, "E")
Me.txtPriority =wsProjectData.Cells(lngPopulateRow, "F")
Me.cboNumberSamples =wsProjectData.Cells(lngPopulateRow, "G")
End Sub
在代码中添加了一些注释，供参考。
示例工作簿
代码太长，但很简洁明了，可以作为一个模板，稍作修改即可用于其它输入、查找和编辑的情形。如果你有类似的需求或者想要进一步研究，可以下载示例工作簿。
在完美Excel微信公众号底部发送消息：
交互式用户窗体
即可获取下载链接。