《Excel VBA跟卢子一起学早做完，不加班(实战进阶版)》_2.9.1 通过双击单元格从与其内容相同的单元格创建新表*

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

2.9.1 通过双击单元格从与其内容相同的单元格创建新表*

假设现在需要双击单元格获取表中与其内容相同的单元格，并将这些数据内容复制到新表， 相当于创建一份副表。示例过程如代码 2-8 所示。

代码2-8 双击创建指定单元格内容的新表

001Private Sub Worksheet_BeforeDoubleClick(By Val Target As Range,Cancel As Boolean)

002| Application.ScreenUpdating =False

003|

Cancel =True

004|

On Error Resume Next

0051

With Target

006| If.Row<3 Or.Value =""Then Exit Sub

007| Dim Sht_Rng As Range,F_Rng As Range,FirstAddress As String,Jh_Rng As Range

008| Set Sht_Rng=Me.Cells(3,.Column),.Resize(Me.UsedRange.Rows.Count-2,I)

009| Set F_Rng=Sht_Rng.Find(What:=.Value,LookAt:=xlWhole)

010| FirstAddress =F_Rng.Address

011| Set Jh_Rng=F_Rng

012| Do

013 Set F_Rng=Sht_Rng.FindNext(F_Rng)

014| IfF_Rng.Address(0,0)～ FirstAddress Then Set Jh_Rng=Application.Union(Jh_Rng,F_Rng)

015| Loop While F_Rng.Address ～ FirstAddress

016| Dim Sht As Worksheet,Rng As Range,Cous As Long

0171

Worksheets(.Value).Visible=1

018|

If Er.Number 0 Then

019| Worksheets.Add After:=Me,Count:=1,Type:=xIWorksheet

020| ActiveSheet.Name =.Value

021| Me.Cells(1).Resize(2).EntireRow.Copy ActiveSheet.Cells(1)

022| Else

023| Worksheets(.Value).Cells(3,1).Resize(Rows.Count-2,Columns.Count).Clear

024| End If

025| For Each Rng In Jh_Rng

026| Cous=ActiveSheet.UsedRange.Rows.Count

0271 Rng.EntireRow.Copy ActiveSheet.UsedRange.Offset(Cous)

028| Next Rng

029| Me.Rows(2).Copy

030| ActiveSheet.Rows(2).PasteSpecial Paste:=xIPasteColumnWidths

031 End With

032| Application.ScreenUpdating =True

0331 Me.Select

034|End Sub

代码2-8示例过程即双击操作的运用，现在来讲讲主要语句的作用。

(1)关闭屏幕刷新；Cancel参数赋值为 True,表示双击触发事件后将不进入单元格编辑

状 态 ；If.Row<3 Or.Value=”” 判断语句的作用在于若双击的位置是空白或者第3行以上的位

置则不响应事件过程。

(2)Me.Cells(3,.Column).Resize(Me.UsedRange.Rows.Count -2,1)语句为通过以双击 位置列的有效范围赋值给 Sht_Rng变量； F_Rng 变量则是通过Sht_Rng.Find(What:=.Value, LookAt:=X1Whole) 语句精确查找双击单元格内容的第1个单元格赋值获取，并将该变量赋值给 FirstAddress 变量； FirstAddress 变量用来记录第1个查找到的单元文本位置，作为后面 Range. Find 方法的单元格位置比较； Jh_Rng则是作为找到的所有相同内容单元格的集合，这里第1 次 Find 须将其单元格位置赋值给 Jh_Rng 变 量 。

(3)找到第1个位置后，通过Do 循环： Set F_Rng=Sht_Rng.FindNext(F_Rng)语句为在 Sht_Rng区域内查找下一个相同内容的单元格，并通过If F_Rng.Address(0,0)～ FirstAddress 语句判断该单元格位置与第1次若不同，则通过Application.Uni on 方法将找到的新单元格赋值 并入Jh_Rng变量，直到下一单元位置与FirstAddress 变量相同时退出 Do 循环，进入下一步。

(4)Worksheets(.Value).Visible =1 语句在这里是将双击单元格的内容同名的工作表属性 设置为显示状态，如果工作簿中存在该同名工作表，此设置将不会有错误提示；如果不存在 时将出现【下标越界】的错误提示。但是这里还可以继续执行，因为最开始时已经设置了On Error Resume Next 容错语句。

(5)If Err.Number ～0 语句承接了上面容错语句的反馈结果。其中 Err.Number 用于判断 错误信息代码，如果不存在错误 Err.Number 将返回0,错误时将返回相应的错误数字。所以这 里用 Err.Numbe r 来判断如果对应表不存在时，通过 Worksheets.Add 方法新建工作表，并通过 ActiveSheet.Name=.Value 将 新 建 命 名 为 双 击 单 元 格 的 内 容 ；Me.Cells(1).Resize(2).EntireRow.Copy ActiveSheet.Cells(1)语句则是将当前表的第1、2行复制到新建表的第1个单元格。如果 Err.Number=0时，则执行 Worksheets(.Value).Cells(3,1).Resize(Rows.Count -2,Columns.Count). Clear语句，其作用是将新建表标题以下的内容及格式等都进行清除。

(6)通过Jh_Rng 对象循环逐个复制到新表中——其中 ActiveSheet.UsedRange.Rows.Count 语句为统计新表已使用的区域行范围，并将其赋值给 Cous 用于下一语句的偏移行位置； Rng. EntireRow.Copy 语句为将聚合单元的整行复制，复制到新表已使用区域的下一空行，UsedRange . Offset(Cous)代表从已有区域的第1个单元格偏移已使用区域的总行数为位置，偏移的位置为 下一个非使用区域的位置。

(7)Me.Rows(2).Copy 为复制双击表的第2行，接着使用Range.PasteSpecial,在新表的 第2行粘贴列宽，最后重新开启屏幕刷新，并选中双击的表。

皮蛋：试了，挺好用的，有点像透视表筛选双击获取需要的清单列表一样。但是里头好像 多了几个新的方法和属性。

无言：是的，本示例过程中用到了3个新方法/属性，这里刚好一起讲了。

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