End Sub
109、选择到指定列的最后行
Sub 选择到指定列的最后行()
Range(\End Sub
110、将Sheet1的A列的非空值写到Sheet2的A列
Sub 将Sheet1的A列的非空值写到Sheet2的A列()
Sheet1.Columns(\End Sub
111、将名称1的数据写到名称2
Sub Macro2()
Range(\位置2\位置1\alue End Sub
112、单元反选
Sub 单元反选()
Application.DisplayAlerts = False Application.ScreenUpdating = False
Dim raddress As String, taddress As String raddress = Selection.Address
taddress = ActiveSheet.UsedRange.Address With Sheets.Add .Range(taddress) = 0
.Range(raddress) = \
raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address .Delete
End With
ActiveSheet.Range(raddress).Select Application.ScreenUpdating = True End Sub
113、调整选中对象中的文字
Sub 调整选中对象中的文字() '文字居中、自动调整大小
With Selection
.HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext .Orientation = xlHorizontal .AutoSize = True .AddIndent = False End With End Sub
114、去除指定范围内的对象
Sub 去除指定范围内的对象() Dim p As Shape
Set My = Worksheets(\工作表名\
For Each p In My.Shapes
If Not Application.Intersect(p.TopLeftCell, Range(\范围\ Next End Sub
115、更新透视表数据项
Sub DeleteMissingItems2002All()
'防止数据透视表中显示无用的数据项 '在 Excel 2002 或更高版本中 '如果无用的数据项已经存在, '运行这个宏可以更新 Dim pt As PivotTable Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets For Each pt In ws.PivotTables
pt.PivotCache.MissingItemsLimit = xlMissingItemsNone Next pt Next ws End Sub
116、将全部工作表名称写到A列
Sub 将全部表名称写到A列()
k = 1
For Each Sht In Sheets
Cells(k + 1, 1) = Sht.Name '指定写入的行和列 k = k + 1 Next End Sub
117、为当前选定的多单元插入指定名称
Sub 为当前选定的多单元插入指定名称()
Selection.Name = \临时\
ActiveWorkbook.Names.Add Name:=\临时\End Sub
118、删除全部名称
Sub 删除全部名称() On Error Resume Next
Dim l As Integer
l = ActiveWorkbook.Names.Count For i = l To 1 Step -1
ActiveWorkbook.Names(i).Delete Next End Sub
119、以指定区域为表目录补充新表
Sub 以指定区域为表目录补充新表() Dim dic As Object, sh As Worksheet Dim arr, item
arr = Range(\
Set dic = CreateObject(\ For Each sh In ThisWorkbook.Worksheets dic.Add sh.Name, \ Next
For Each item In arr
If item <> \ With ThisWorkbook.Worksheets.Add .Name = item End With
'或者换用这行代码也可以 End If
Next
Set dic = Nothing End Sub
120、按A列数据批量修改表名称
Sub 按A列数据批量修改表名称() Dim i%
For i = 1 To Sheets.Count - 1
Sheets(i).Name = Cells(i + 1, 1).Text Next End Sub
121、按A列数据批量创建新表(控件按钮代码)
Private Sub CommandButton1_Click() On Error Resume Next Dim i%, j%
For i = 1 To [a65536].End(xlUp).Row For j = 2 To Sheets.Count
If Cells(i, 1) = Sheets(j).Name Then Exit For End If
Next
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Cells(i, 1) Next End Sub
122、清除剪贴板
Sub 清除剪贴板()
Application.CutCopyMode = False
Application.CommandBars(\isible = False End Sub
123、批量清除软回车
Sub 批量清除软回车()
'也可直接使用Alt+10或13替换
Cells.Replace What:=Chr(10), Replacement:=\
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub
124、判断指定文件是否已经打开
Sub 判断指定文件是否已经打开()
Dim x As Integer
For x = 1 To Workbooks.Count
If Workbooks(x).Name = \函数.xls\ '文件名称 MsgBox \文件已打开\ Exit Sub End If Next
MsgBox \文件未打开\End Sub
125、当前文件另存到指定目录
Sub 当前激活文件另存到指定目录()
ActiveWorkbook.SaveAs Filename:=\信件\\\End Sub
126、另存指定文件名
Sub 另存指定文件名()
ActiveWorkbook.SaveAs ThisWorkbook.Path & \别名.xls\End Sub
127、以本工作表名称另存文件到当前目录
Sub 以本工作表名称另存文件到当前目录()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & \End Sub
128、将本工作表单独另存文件到Excel当前默认目录
Sub 将本工作表单独另存文件到Excel当前默认目录()
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \
