书接上文，上一篇主要写了如何用代码动态创建控件，这一章讲讲如何具体实现我们需要的功能。

五、功能性代码

我们添加两个OptionButton的目的就是为了切换到对应的工具，所以，我们需要的是在点击了相对应的OptionButton之后能够切换到工具对应的Frame框架，以下是对应的代码：

' 点击提取
Private Sub optExtract_Click()
		On Error Resume Next ' 添加错误处理

		' 检查框架是否存在
		If Not FrameExists("frameExtract") Then
				lblStatus.Caption = "框架初始化失败，请重新加载窗体"
				Exit Sub
		End If

		' 显示/隐藏框架
		Me.Controls("frameExtract").Visible = True '显示提取Frame
		Me.Controls("frameCompare").Visible = False '隐藏对比Frame
		lblStatus.Caption = "提取工作簿中包含特定字符串的所有单元格" '同时变更状态标签的内容
End Sub

'点击对比
Private Sub optCompare_Click()
		On Error Resume Next ' 添加错误处理
		' 检查框架是否存在
		If Not FrameExists("frameCompare") Then
				lblStatus.Caption = "框架初始化失败，请重新加载窗体"
				Exit Sub
		End If
		' 显示/隐藏框架
		Me.Controls("frameExtract").Visible = False  '隐藏提取Frame
		Me.Controls("frameCompare").Visible = True '显示对比Frame
		lblStatus.Caption = "比较两个工作簿版本并生成变更日志" '同时变更状态标签的内容
End Sub

下面是检查框架Frame是否存在的辅助函数：

' 添加辅助函数检查框架是否存在
Private Function FrameExists(frameName As String) As Boolean
		On Error GoTo NotExist
		Dim testObj As Object

		' 尝试访问框架控件
		Set testObj = Me.Controls(frameName)
		FrameExists = True
		Exit Function

NotExist:
		FrameExists = False
End Function

另外，需要添加执行和取消的函数以执行具体的功能：

' 执行按钮 - 更新版本
Private Sub cmdRun_Click()
		If optExtract.value Then
				DoExtract '提取功能所对应的功能函数
		Else
				If chkAdvanced.value Then
						DoSmartCompare ' 使用智能对比
				Else
						DoCompare ' 使用基础对比
				End If
		End If
End Sub
' 取消按钮
Private Sub cmdCancel_Click()
		Unload Me
End Sub

以下是提取功能的具体实现函数：

' 提取功能
Private Sub DoExtract()
		Dim targetWorkbook As Workbook '不是本工作簿时选择的工作簿对象
		Dim searchPattern As String '输入的需要查找的文本
		Dim resultSheet As Worksheet '需要输出结果到的sheet 对象
		Dim cell As Range	'单元格对象
		Dim sourceSheet As Worksheet '
		Dim foundCount As Long
		Dim extractLength As Long '输入的自定义长度
		Dim useRegex As Boolean '正则表达式是否勾选

		' 获取搜索模式
		searchPattern = txtPattern.text
		If searchPattern = "" Then
				MsgBox "请输入要查找的内容", vbExclamation
				txtPattern.SetFocus
				Exit Sub
		End If

		' 获取提取长度-单独的函数(txtExtractLength)实现
		If IsNumeric(txtExtractLength.text) And val(txtExtractLength.text) > 0 Then
				extractLength = val(txtExtractLength.text)
		Else
				extractLength = 0 ' 0表示不限制长度
		End If

		' 检查是否使用正则表达式
		useRegex = chkRegexMode.value


		' 选择工作簿 - 使用复选框值
		If chkCurrentWorkbook.value Then
				Set targetWorkbook = ThisWorkbook
		Else
				Dim filePath As String
				filePath = ShowFileDialog("选择要处理的工作簿")
				If filePath = "" Then Exit Sub
				Set targetWorkbook = Workbooks.Open(filePath)
		End If

		' 创建结果表
		On Error Resume Next
		Set resultSheet = targetWorkbook.Sheets("提取结果")
		If Not resultSheet Is Nothing Then
				Application.DisplayAlerts = False
				resultSheet.Delete
				Application.DisplayAlerts = True
		End If
		On Error GoTo 0

		Set resultSheet = targetWorkbook.Sheets.Add(After:=targetWorkbook.Sheets(targetWorkbook.Sheets.count))
		resultSheet.Name = "提取结果"
		resultSheet.Range("A1:E1") = Array("工作簿", "工作表", "单元格", "单元格内容", "提取的字符串")

		' 遍历所有工作表
		foundCount = 0
		For Each sourceSheet In targetWorkbook.Sheets
				If sourceSheet.Name <> resultSheet.Name Then
						For Each cell In sourceSheet.UsedRange
								Dim cellText As String
								cellText = CStr(cell.text)

								' 检查是否包含搜索模式
								Dim extractedStr As String
								Dim matchFound As Boolean
								matchFound = False

								If useRegex Then
								' 使用正则表达式提取
										extractedStr = ExtractWithRegex(cellText, searchPattern, extractLength)
										matchFound = (extractedStr <> "")
								Else
								' 使用精确匹配或部分匹配
										If extractLength > 0 Then
										' 查找指定长度的匹配
												extractedStr = FindExactMatch(cellText, searchPattern, extractLength)
												matchFound = (extractedStr <> "")
										Else
										' 检查是否包含搜索字符串
												If InStr(1, cellText, searchPattern, vbTextCompare) > 0 Then
														extractedStr = "" ' 不提取具体字符串
														matchFound = True
												End If
										End If
								End If

								' 如果有匹配项
								If matchFound Then
										foundCount = foundCount + 1
										resultSheet.Cells(foundCount + 1, 1) = targetWorkbook.Name
										resultSheet.Cells(foundCount + 1, 2) = sourceSheet.Name
										resultSheet.Cells(foundCount + 1, 3) = cell.Address(False, False)
										resultSheet.Cells(foundCount + 1, 4) = "'" & cellText
										resultSheet.Cells(foundCount + 1, 5) = extractedStr
								End If
						Next cell
				End If
		Next sourceSheet

		' 格式化结果
		If foundCount > 0 Then
				resultSheet.Columns("A:E").AutoFit

				' 添加表格格式
				On Error Resume Next
				resultSheet.ListObjects.Add(xlSrcRange, resultSheet.UsedRange, , xlYes).Name = "ResultTable"
				On Error GoTo 0

				lblStatus.Caption = "找到 " & foundCount & " 个匹配项! 结果已保存到'" & resultSheet.Name & "'工作表"

				' 添加超链接到单元格地址
				Dim i As Long
				For i = 2 To foundCount + 1
						Dim sheetName As String, cellAddr As String
						sheetName = resultSheet.Cells(i, 2).value
						cellAddr = resultSheet.Cells(i, 3).value

						resultSheet.Hyperlinks.Add Anchor:=resultSheet.Cells(i, 3), Address:="", SubAddress:="'" & sheetName & "'!" & cellAddr, TextToDisplay:=cellAddr
				Next i
		Else
				Application.DisplayAlerts = False
				resultSheet.Delete
				Application.DisplayAlerts = True
				lblStatus.Caption = "未找到匹配项"
		End If

		' 激活结果表
		If Not chkCurrentWorkbook.value Then
				targetWorkbook.Activate
				If foundCount > 0 Then resultSheet.Select
		Else
				ThisWorkbook.Activate
				If foundCount > 0 Then resultSheet.Select
		End If

		' 如果是外部工作簿，提示保存
		If Not chkCurrentWorkbook.value Then
				If MsgBox("是否保存更改到外部工作簿?", vbYesNo + vbQuestion) = vbYes Then
						targetWorkbook.Save
				End If
		End If
End Sub

' 函数：精确匹配指定长度的字符串

' 函数：精确匹配指定长度的字符串
Private Function FindExactMatch(fullText As String, searchPattern As String, extractLength As Long) As String
Dim pos As Long
Dim startPos As Long
Dim endPos As Long
Dim matchText As String

startPos = 1
Do
' 查找搜索模式出现的位置
pos = InStr(startPos, fullText, searchPattern, vbTextCompare)
If pos = 0 Then Exit Do

' 检查是否满足长度条件
If (pos + extractLength - 1) <= Len(fullText) Then
matchText = Mid(fullText, pos, extractLength)

' 检查是否以搜索模式开头
If Left(matchText, Len(searchPattern)) = searchPattern Then
FindExactMatch = matchText
Exit Function
End If
End If

' 继续搜索下一个位置
startPos = pos + 1
Loop While startPos <= Len(fullText)

FindExactMatch = ""
End Function

正则表达式提取函数

'正则表达式提取函数
Private Function ExtractWithRegex(fullText As String, pattern As String, extractLen As Long) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")

With regex
.Global = True
.MultiLine = True
.IgnoreCase = True ' 不区分大小写
.pattern = pattern
End With

Dim matches As Object
Set matches = regex.Execute(fullText)

If matches.count > 0 Then
Dim match As Object
Set match = matches(0)

If extractLen > 0 Then
' 提取指定长度
ExtractWithRegex = Left(match.value, extractLen)
Else
' 提取整个匹配
ExtractWithRegex = match.value
End If
Else
ExtractWithRegex = ""
End If
End Function

以上就是所有提取工具的代码部分，感兴趣的可以连着前面章节的步骤操作试试~