清除剪贴板
Sub 清除剪贴板()
Application.CutCopyMode = False
Application.CommandBars(\End Sub
批量清除软回车
Sub 批量清除软回车()
'也可直接使用Alt+10或13替换
Cells.Replace What:=Chr(10), Replacement:=\ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub
判断指定文件是否已经打开
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
当前文件另存到指定目录
Sub 当前激活文件另存到指定目录()
ActiveWorkbook.SaveAs Filename:=\信件\\\End Sub
另存指定文件名
Sub 另存指定文件名()
ActiveWorkbook.SaveAs ThisWorkbook.Path & \别名.xls\End Sub
以本工作表名称另存文件到当前目录
Sub 以本工作表名称另存文件到当前目录()
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & \End Sub
将本工作表单独另存文件到Excel当前默认目录
Sub 将本工作表单独另存文件到Excel当前默认目录() ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \End Sub
以活动工作表名称另存文件到Excel当前默认目录
Sub 以活动工作表名称另存文件到Excel当前默认目录()
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \
xlNormal, Password:=\ , CreateBackup:=False End Sub
另存所有工作表为工作簿
Sub 另存所有工作表为工作簿() Dim sht As Worksheet
Application.ScreenUpdating = False ipath = ThisWorkbook.Path & \For Each sht In Sheets sht.Copy
ActiveWorkbook.SaveAs ipath & sht.Name & \工作表名称为文件名）
'ActiveWorkbook.SaveAs ipath & sht.Name & Trim(sht.[d15]) & \（文件名称 & D15单元内容）
'ActiveWorkbook.SaveAs ipath & Trim(sht.[d15]) & \ '（文件名称为D15单元内容） ActiveWorkbook.Close Next
Application.ScreenUpdating = True End Sub
以指定单元内容为新文件名另存文件
Sub 以指定单元内容为新文件名另存文件()
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & \End Sub
以当前日期为新文件名另存文件
Sub 以当前日期为新文件名另存文件()
ThisWorkbook.SaveAs ThisWorkbook.Path & \End Sub
Sub 以当前日期为名称另存文件()
ActiveWorkbook.SaveAs Filename:=Date & \ End Sub
以当前日期和时间为新文件名另存文件
Sub 以当前日期和时间为新文件名另存文件()
ThisWorkbook.SaveAs ThisWorkbook.Path & \年\月\日\时\分\秒\End Sub
另存本表为TXT文件
Sub 另存本表为TXT文件() Dim s As String
Dim FullName As String, rng As Range Application.ScreenUpdating = False
FullName = (ActiveSheet.Name & \ '以当前表名为TXT文件名
' FullName = Replace(ThisWorkbook.FullName, \ '以当前文件名为TXT文件名 ' FullName = Replace(ThisWorkbook.FullName, \'以文件名&表名为TXT文件名
Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容
'参考帮助，fullname为文件全名
For Each rng In Range(\ s = s & IIf(s = \|\
If rng.Column = Range(\ Print #1, s & \|\'把数据写到文本文件里 s = \ End If Next
Close #1 '关闭文件
Application.ScreenUpdating = True MsgBox \数据已导入文本\ End Sub
引用指定位置单元内容为部分文件名另存文件
Sub 引用指定位置单元内容为部分文件名另存文件()
ActiveWorkbook.SaveAs Filename:=\信件\\\解答\郎雀.xls\End Sub
将A列数据排序到D列
Sub 将A列数据排序到D列() [d:d] = [a:a].Value
[d:d].Sort Key1:=Range(\
End Sub
将指定范围的数据排列到D列
Sub 将指定范围的数据排列到D列() Dim arr1, arr2, i%, x arr1 = Range(\
ReDim arr2(1 To UBound(arr1, 1) * UBound(arr1, 2), 1 To 1) For Each x In Application.Transpose(arr1) i = i + 1 arr2(i, 1) = x Next x
Range(\End Sub 光标移动
Sub 光标移动()
ActiveCell.Offset(1, 2).Select '向下移动1行，向右移动2列 End Sub
光标所在行上移一行
Sub 光标所在行上移一行() Dim i%
i = Split(ActiveCell.Address, \ If i > 1 Then Rows(i).Cut
Rows(i - 1).Insert Shift:=xlDown End If End Sub
加数据有效限制
Sub 加数据有效限制()
With Selection.Validation .Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=\bigsun010@sina.com\ .IgnoreBlank = False .InCellDropdown = False .InputTitle = \ .ErrorTitle = \ .InputMessage = \
.ErrorMessage = \要奋斗就会有牺牲，死人的事是经常发生的。\ .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With End Sub
取消数据有效限制
Sub 取消数据有效限制() With Selection.Validation .Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween
.IgnoreBlank = False .InCellDropdown = False .InputTitle = \ .ErrorTitle = \ .InputMessage = \ .ErrorMessage = \
.IMEMode = xlIMEModeNoControl .ShowInput = True
.ShowError = True End With End Sub 重排窗口
Sub 重排窗口()
Application.CommandBars(\
Application.CommandBars(\我的工具\ Windows.Arrange ArrangeStyle:=xlCascade End Sub
按当前单元文本选择打开指定文件单元 Sub 选择打开文件单元() Dim a
a = ActiveCell.Value
Range(a).Worksheet.Activate Range(a).Select End Sub
回车光标向右
Sub 录入光标向右()
Application.MoveAfterReturnDirection = xlToRight End Sub
回车光标向下
Sub 录入光标向下()
Application.MoveAfterReturnDirection = xlDown End Sub
保护工作表时取消选定锁定单元 Sub 取消选定锁定单元()
ActiveSheet.EnableSelection = xlUnlockedCells '用于2000版 End Sub
保存并退出Excel
Sub 保存并退出Excel()
Application.SendKeys (\ActiveWorkbook.Save End Sub
隐藏/显示指定列空值行 Sub 隐藏显示E列空值行()
Range(\(Range(\ End Sub
深度隐藏指定工作表
Sub 深度隐藏指定工作表()
Sheets(\用户名密码\End Sub
隐藏指定工作表
Sub 隐藏指定工作表()
Sheets(\用户名密码\End Sub
隐藏当前工作表
Sub 隐藏当前工作表()
ActiveWindow.SelectedSheets.Visible = false End Sub
返回当前工作表名称
Sub 返回当前工作表名称() wsName = ActiveSheet.Name
MsgBox \当前工作表为：\
End Sub
获取上一次所进入工作簿的工作表名称
Sub 获取上一次所进入工作簿的工作表名称() MsgBox Workbooks(2).ActiveSheet.Name End Sub
按光标选定颜色隐藏本列其他颜色行
Sub 按颜色筛选() '思路就是:其它背景色之行全部隐藏
Dim UseRow, AC, i '首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏 UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格
If ActiveCell.Row > UseRow Then
MsgBox \请在要筛选的区域选择一个有颜色之单元格！\错误\Else
AC = ActiveCell.Column
Cells.EntireRow.Hidden = False '显示所有行 For i = 2 To UseRow
If Cells(i, AC).Interior.ColorIndex <> ActiveCell.Interior.ColorIndex Then
Cells(i, AC).EntireRow.Hidden = True '如果2至已用行之单元格的有列之颜色不等于当前单元格颜色则隐藏整行 End If Next End If End Sub
打开工作簿自动隐藏录入表以外的其他表 Private Sub Workbook_Open() Dim i
For i = 1 To Sheets.Count
If Sheets(i).Name <> \录入\Sheets(i).Visible = False End If Next End Sub
除最左边工作表外深度隐藏所有表
Sub 除最左边工作表外深度隐藏所有表() For i = 2 To ThisWorkbook.Sheets.Count Sheets(i).Visible = xlSheetVeryHidden Next End Sub
关闭文件时自动隐藏指定工作表(ThisWorkbook) Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect
Sheets(\ Sheets(\
ActiveWorkbook.Protect Structure:=True, Windows:=False End Sub
打开文件时提示指定工作表是保护状态(ThisWorkbook) Private Sub Workbook_Open()
If Worksheets(\ MsgBox \保护了.\End If End Sub 插入10行
Sub 插入10行()
Rows(ActiveCell.Row & \ Selection.Insert Shift:=xlDown