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