Excel常见宏(简洁版).doc

清除剪贴板Sub 清除剪贴板()Application.CutCopyMode = FalseApplication.CommandBars("Task Pane").Visible = FalseEnd Sub批量清除软回车Sub 批量清除软回车()'也可直接使用 Alt+10 或 13 替换Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=FalseEnd Sub判断指定文件是否已经打开Sub 判断指定文件是否已经打开()Dim x As IntegerFor x = 1 To Workbooks.CountIf Workbooks(x).Name = "函数.xls" Then '文件名称MsgBox "文件已打开"Exit SubEnd IfNextMsgBox "文件未打开"End Sub当前文件另存到指定目录Sub 当前激活文件另存到指定目录()ActiveWorkbook.SaveAs Filename:="E:\信件\" & ActiveWorkbook.NameEnd Sub另存指定文件名Sub 另存指定文件名()ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls"End Sub以本工作表名称另存文件到当前目录Sub 以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"End Sub将本工作表单独另存文件到 Excel 当前默认目录Sub 将本工作表单独另存文件到 Excel 当前默认目录()ActiveSheet.CopyActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls"End Sub以活动工作表名称另存文件到 Excel 当前默认目录Sub 以活动工作表名称另存文件到 Excel 当前默认目录()ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls", FileFormat:= _xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _, CreateBackup:=FalseEnd Sub另存所有工作表为工作簿Sub 另存所有工作表为工作簿()Dim sht As WorksheetApplication.ScreenUpdating = Falseipath = ThisWorkbook.Path & "\"For Each sht In Sheetssht.CopyActiveWorkbook.SaveAs ipath & sht.Name & ".xls" '(工作表名称为文件名） 'ActiveWorkbook.SaveAs ipath & sht.Name & Trim(sht.[d15]) & ".xls" '（文件名称 & D15单元内容）'ActiveWorkbook.SaveAs ipath & Trim(sht.[d15]) & ".xls" '（文件名称为 D15 单元内容）ActiveWorkbook.CloseNextApplication.ScreenUpdating = TrueEnd Sub以指定单元内容为新文件名另存文件Sub 以指定单元内容为新文件名另存文件()ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1]End Sub以当前日期为新文件名另存文件Sub 以当前日期为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls"End SubSub 以当前日期为名称另存文件()ActiveWorkbook.SaveAs Filename:=Date & ".xls"End Sub以当前日期和时间为新文件名另存文件Sub 以当前日期和时间为新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls"End Sub另存本表为 TXT 文件Sub 另存本表为 TXT 文件()Dim s As StringDim FullName As String, rng As RangeApplication.ScreenUpdating = FalseFullName = (ActiveSheet.Name & ".txt") '以当前表名为 TXT 文件名' FullName = Replace(ThisWorkbook.FullName, ".xls", ".txt") '以当前文件名为 TXT 文件名' FullName = Replace(ThisWorkbook.FullName, ".xls", ActiveSheet.Name & ".txt") '以文件名&表名为 TXT 文件名Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容'参考帮助，fullname 为文件全名For Each rng In Range("a1").CurrentRegions = s & IIf(s = "", "", "|") & rng.ValueIf rng.Column = Range("a1").CurrentRegion.Columns.Count ThenPrint #1, s & "|" '把数据写到文本文件里s = ""End IfNextClose #1 '关闭文件Application.ScreenUpdating = TrueMsgBox "数据已导入文本"End Sub引用指定位置单元内容为部分文件名另存文件Sub 引用指定位置单元内容为部分文件名另存文件()ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls"End Sub将 A 列数据排序到 D 列Sub 将 A 列数据排序到 D 列()[d:d] = [a:a].Value[d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYesEnd Sub将指定范围的数据排列到 D 列Sub 将指定范围的数据排列到 D 列()Dim arr1, arr2, i%, xarr1 = Range("A1:C3")ReDim arr2(1 To UBound(arr1, 1) * UBound(arr1, 2), 1 To 1)For Each x In Application.Transpose(arr1)i = i + 1arr2(i, 1) = xNext xRange("D1").Resize(i, 1) = arr2End Sub光标移动Sub 光标移动()ActiveCell.Offset(1, 2).Select '向下移动 1 行，向右移动 2 列End Sub光标所在行上移一行Sub 光标所在行上移一行()Dim i%i = Split(ActiveCell.Address, "$")(2)If i > 1 ThenRows(i).CutRows(i - 1).Insert Shift:=xlDownEnd IfEnd Sub加数据有效限制Sub 加数据有效限制()With Selection.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _xlBetween, Formula1:="bigsun010@".IgnoreBlank = False.InCellDropdown = False.InputTitle = "".ErrorTitle = "".InputMessage = "".ErrorMessage = "要奋斗就会有牺牲，死人的事是经常发生的。

".IMEMode = xlIMEModeNoControl.ShowInput = True.ShowError = TrueEnd WithEnd 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 = TrueEnd WithEnd Sub重排窗口Sub 重排窗口()Application.CommandBars("Web").Visible = FalseApplication.CommandBars("我的工具").Visible = FalseWindows.Arrange ArrangeStyle:=xlCascadeEnd Sub按当前单元文本选择打开指定文件单元Sub 选择打开文件单元()Dim aa = ActiveCell.ValueRange(a).Worksheet.ActivateRange(a).SelectEnd Sub回车光标向右Sub 录入光标向右()Application.MoveAfterReturnDirection = xlToRightEnd Sub回车光标向下Sub 录入光标向下()Application.MoveAfterReturnDirection = xlDownEnd Sub保护工作表时取消选定锁定单元Sub 取消选定锁定单元()ActiveSheet.EnableSelection = xlUnlockedCells '用于 2000 版End Sub保存并退出 ExcelSub 保存并退出 Excel()Application.SendKeys ("{ENTER}{ENTER}%fx")ActiveWorkbook.SaveEnd Sub隐藏/显示指定列空值行Sub 隐藏显示 E 列空值行()Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = Not (Range("E1:E1000").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)End Sub深度隐藏指定工作表Sub 深度隐藏指定工作表()Sheets("用户名密码").Visi。