《Excel VBA跟卢子一起学早做完，不加班(实战进阶版)》_3.3 工作簿单元格改变事件拆分工作簿

【摘要】 本书摘自《Excel VBA跟卢子一起学早做完，不加班(实战进阶版)》一书中第3章，第3节，陈锡卢、李应钦著。

3.3 工作簿单元格改变事件拆分工作簿:Workbook.SheetChange

根据关键字段和关键字，从工作簿的所有表中提取满足条件的所有数据，并将创建一个 新的工作簿，并运用Workbook.SheetChange 事件，其事件过程外壳及示例代码(见代码3-2) 如下。

当用户或外部链接更改了任何工作表中的单元格时发生此事件

Private Sub Workbook_SheetChange(By Val Sh As Object,By Val Target As Range)

Statements(中间代码语句)

End Sub

代码3-2 根据关键字获取数据并新建工作簿

001Rem 通过控制选择的工作表和单元格位置，创建数据有效性

002|Private Sub Workbook_SheetSelectionChange(By Val Sh As Object,By Val Target As Range)

0031 Application.EnableEvents =True:Application.DisplayAlerts =True:Application.ScreenUpdating =True

004| If Sh.CodeName="Sheetl"And Target.Address(0,0)="B1"Then

005| With Target.Validation

006| .Delete

0071 .Add xIValidateList,Formulal1:=“华北地区，东北地区，华东地区，中南地区，西南地区，西北地区”

008| End With

009| End If

010|End Sub

011

012|Rem 根据指定单元格的位置内容判断关键字

013|Private Sub Workbook_SheetChange(By Val Sh As Object,By Val Target As Range)

014| Dim ShtCou As Long,Tem_Sht As Worksheet

0151 Dim New_Wb As Workbook,NewSht As Worksheet,NewShtRow As Long

016| Dim Val Str,Cous As Long

0171 Dim OneFind_Add As String,Find_Rng As Range,Union_Rng As Range

018| Dim OldWb_Luj As String

019| OldWb_Luj =ActiveWorkbook.Path&""

020| If Sh.CodeName "Sheet1"And Target.Address(0,0)～ "B1"Then Exit Sub

021 Application.ScreenUpdating=False:Application.EnableEvents =False

022| Application.DisplayAlerts =False

0231 If Target.Value =""Then'如果单元格内容为空

024| For Each Val_Str In Split(Target.Validation.Formulal,",")

0251 With Worksheets.Add(Before:=Sh,Count:=1,Type:=xlWorksheet)

026| .Name =Val_Str

0271 Worksheets(Worksheets.Count),.Rows(1).Copy.Cells(1)

028| End With

029| Set NewSht =Worksheets(Val_Str)

030| For Sht=1 To ActiveWorkbook.Worksheets.Count

0311 Set Tem_Sht =Worksheets(Sht)

032| IfTem_Sht.CodeName "Sheet1"And Tem_Sht.Name ～ Val_Str Then

0331 If WorksheetFunction.CountIf(Tem_Sht.Columns(4),Val_Str)>0 Then

034| Set Find_Rng=Tem_Sht.Columns(4).Find(What:=Val_Str)

035| OneFind_Add=Find_Rng.Address(0,0)

036| Set Union_Rng=Find_Rng

0371 Do

038| Set Find_Rng=Tem_Sht.Columns(4).FindNext(Find_Rng)

039| Set Union_Rng=Application.Union(Union_Rng,Find_Rng)

040| Loop While Find_Rng.Address(0,0)～ OneFind_Add

041|

042| With NewSht

043| NewShtRow=NewSht.UsedRange.Rows.Count

044| Union_Rng.EntireRow.Copy.Cells(1).Offset(NewShtRow)

045| End With

046| End If

047| End If

048| Set Find_Rng=Nothing;Set Union_Rng=Nothing:OneFind_Add=""

049| Next Sht

050| If NewSht.UsedRange.Rows.Count>1 Then

051| Set New_Wb=Workbooks.Add:NewSht.Activate

052| NewSht.Copy Before:=New_Wb.Worksheets(1)

053| Worksheets(Val_Str).UsedRange.Columns.AutoFit

054| New_Wb.SaveAs Filename:=OldWb_Luj&Val_Str,FileFormat:=xIWorkbookDefault

055| New_Wb.Close:NewSht.Delete

056| Else

0571 NewSht.Delete

058| End If

059 Next Val_Str

060| Else

061| Val_Str=Target.Value

062| With Worksheets.Add(Before:=Sh,Count:=1,Type:=xIWorksheet)

063| .Name =Val_Str

064 Worksheets(Worksheets.Count).Rows(1).Copy.Cells(1)

065| End With

066| Set NewSht =Worksheets(Val_Str)

0671 For Sht=1 To ActiveWorkbook.Worksheets.Count

068| Set Tem_Sht=Worksheets(Sht)

069| If Tem_Sht.CodeName ～"Sheet1"And Tem_Sht.Name ～ Val_Str Then

070| If WorksheetFunction.Countlf(Tem_Sht.Columns(4),Val_Str)>0 Then

071| Set Find_Rng=Tem_Sht.Columns(4).Find(What:=Val_Str)

072| OneFind_Add=Find_Rng.Address(0,0)

0731 Set Union_Rng=Find_Rng

074| Do

0751 Set Find_Rng=Tem_Sht.Columns(4).FindNext(Find_Rng)

076| Set Union_Rng=Application.Union(Union_Rng,Find_Rng)

077| Loop While Find_Rng.Address(0,0)～ OneFind_Add

078| With NewSht

079| NewShtRow =NewSht.UsedRange.Rows.Count

080| Union_Rng.EntireRow.Copy.Cells(1).Offset(NewShtRow)

081 End With

082| End If

083| End If

084| Set Find_Rng=Nothing:Set Union_Rng=Nothing:OneFind_Add=""

085| Next Sht

086| If NewSht.UsedRange.Rows.Count>1 Then

0871 Set New_Wb=Workbooks.Add:NewSht.Activate

088| Worksheets(Val_Str).UsedRange.Columns.AutoFit

089| NewSht.Copy Before:=New_Wb.Worksheets(1)

090| New_Wb.SaveAs Filename:=OldWb_Luj&Val_Str,FileFormat:=xlWorkbookDefault

091| New_Wb.Close:NewSht.Delete

092| Else

093| NewSht.Delete

094| End If

095| Application.EnableEvents =True:Application.DisplayAlerts =True

096| Application.ScreenUpdating =True

097| End If

098|End Sub

代码3-2示例过程通过Workbook.SheetSelectionChange 事件——开启 Excel 的相关功能提 示和响应，限制用户选取的工作表及单元格位置，并依据满足条件时新建一个数据有效性序 列——区域划分。

第2个事件过程采用 Workbook.SheetChange 事件来获取指定工作表和单元格数据来获取 相关数据。

(1)首先过程中定义几个变量，然后将OldWb_Luj 变量通过 ActiveWorkbook.Path 语句 赋值为当前工作簿的存放完整路径，在赋值时使用&””将所有字符拼接成一个完整的文件存 储路径，作为后续保存文件时链接具体文件名称。

(2)If Sh.CodeName "Sheet1"And Target.Address(0,0)～"B1" 语句用于判断选中表 代码名称和单元格位置是否均满足判断条件，不满足则退出过程 (Exit Sub)。

(3)接着将Application 的3个属性 ScreenUpdating 、EnableEvents 、DisplayAlerts 并都赋 值为 False,它们的作用是关闭屏幕刷新、事件触发、信息窗口提示。

无言：接下来的If Target.Value =”"语句判断单元格内容是否为空，以下的第1部分语句是 要重点讲解的部分。

(4)当判断单元格内容为空时，将获取单元格中的数据有效性的Furmula₁ 参数的文本内 容，通过 Split(Target.Validation.Formulal,",") 语句将文本拆解为一个一维数组 (Split 函数是 以指定字符拆分字符),并通过Val_Str 变量循环获取一维数组中的所有内容。

(5)With Worksheets.Add(Before:=Sh,Count:=1,Type:=X1Worksheet)在指定表前创建新表， 并将其.Name 赋值为Val_Str变量中执行地区的名称，再通过 Worksheets(Worksheets.Count).

Rows(1).Copy.Cells(1)语句将工作簿最后一个表的第1行复制到新建表的第1行作为标题；最 后将新建表赋值给 NewSht 变量。

版权声明：本文内容由网络用户投稿，版权归原作者所有，本站不拥有其著作权，亦不承担相应法律责任。如果您发现本站中有涉嫌抄袭或描述失实的内容，请联系我们 [email protected] 处理，核实后本网站将在24小时内删除侵权内容。