.HorizontalAlignment = Selection.HorizontalAlignment .VerticalAlignment = Selection.VerticalAlignment .WrapText = Selection.WrapText .Orientation = Selection.Orientation .AddIndent = Selection.AddIndent .IndentLevel = Selection.IndentLevel .ShrinkToFit = Selection.ShrinkToFit .MergeCells = Selection.MergeCells .Font.Name = Selection.Font.Name
.Font.FontStyle = Selection.Font.FontStyle .Font.Size = Selection.Font.Size
.Font.Strikethrough = Selection.Font.Strikethrough .Font.Subscript = Selection.Font.Subscript .Font.Underline = Selection.Font.Underline .Font.ColorIndex = Selection.Font.ColorIndex
.Interior.ColorIndex = Selection.Interior.ColorIndex .Interior.Pattern = Selection.Interior.Pattern .Locked = Selection.Locked
.FormulaHidden = Selection.FormulaHidden End With
Set FirstCell = ActiveSheet.UsedRange.Find(what:=\ If FirstCell Is Nothing Then Exit Sub End If
Set AllCells = FirstCell
Set FoundCell = FirstCell Do
Set FoundCell = ActiveSheet.UsedRange.Find(After:=FoundCell, searchformat:=True)
If FoundCell Is Nothing Then Exit Do Set AllCells = Union(FoundCell, AllCells)
If FoundCell.Address = FirstCell.Address Then Exit Do Loop AllCells.Select End Sub
63：按当前单元文本定位
Sub 按当前单元文本定位() ABC = Selection Dim aa As Range
For Each a In ActiveSheet.UsedRange If a Like ABC Then
what:=\ If aa Is Nothing Then Set aa = a.Cells Else
Set aa = Union(aa, a.Cells) End If End If Next aa.Select End Sub
64：按固定文本定位
Sub 文本定位()
Dim aa As Range
For Each a In ActiveSheet.UsedRange If a Like \合计*\ If aa Is Nothing Then Set aa = a.Cells Else
Set aa = Union(aa, a.Cells) End If End If Next aa.Select End Sub
65：删除包含固定文本单元的行或列
Sub 删除包含固定文本单元的行或列() Do
Cells.Find(what:=\哈哈\
Selection.EntireRow.Delete '删除行 ' Selection.EntireColumn.Delete '删除列
Loop Until Cells.Find(what:=\哈哈\End Sub
66：定位数据及区域以上的空值
Sub 定位数据及区域以上的空值() Dim aa As Range
For Each a In ActiveSheet.UsedRange
If a Like 〈0 Then If aa Is Nothing Then Set aa = a.Cells Else
Set aa = Union(aa, a.Cells) End If End If Next aa.Select End Sub
67：右侧单元自动加5(工作表代码)
Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target.Offset(0, 1) = Target + 5 Application.EnableEvents = True End Sub
68：当前单元加2
Sub 当前单元加2()
Selection = Selection + 2
'Selection = Workbooks(\临时表\表2\调用指定地址内容 End Sub
69：A列等于A列减B列
Sub A列等于A列减B列() For i = 1 To 23
Cells(i, 1) = Cells(i, 1) - Cells(i, 2) Next End Sub
70：用于光标选定多区域跳转指定单元(工作表代码)
Private Sub Worksheet_SelectionChange(ByVal T As Range) a = Array([b6:b7], [e6], [h6]) For i = 0 To 2
If Not Application.Intersect(T, a(i)) Is Nothing Then
[a1].Select: Exit For End If Next End Sub
71：将A1单元录入的数据累加到B1单元（工作表代码）
Private Sub Worksheet_Change(ByVal Target As Range) Dim t As Long
If Target.Address = \t = Sheet1.Range(\
Sheet1.Range(\End If End Sub
72：在指定颜色区域选择单元时添加/取消\（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim myrg As Range For Each myrg In Target
If myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg <> \ Next End Sub
73：在指定区域选择单元时添加/取消\（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Rng As Range
If Target.Count <= 15 Then
If Not Application.Intersect(Target, Range(\ For Each Rng In Selection With Rng
If .Value = \ .Value = \ Else
.Value = \ End If End With Next End If End If
End Sub
74：双击指定单元，循环录入文本（工作表代码）
Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean) If T.Address <> \Cancel = True
T = IIf(T = \好\中\中\差\好\End Sub
75：双击指定单元，循环录入文本（工作表代码）
Dim nums As Byte
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = \nums = nums Mod 3 + 1
Target = Mid(\上中下\Target.Offset(1, 0).Select End If End Sub
76：单元区域引用（工作表代码）
Private Sub Worksheet_Activate()
Sheet1.Range(\End Sub
77：在指定区域选择单元时数值加1（工作表代码）
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect([a1:e10], Target) Is Nothing Then Target = Val(Target) + 1 End If End Sub
259个常用宏-excelhome(3) 2009-08-15 14:12:58