Excel常见宏(简洁版)

清除剪贴板Sub清除剪贴板()Application.CutCopyMode=FalseApplication.CommandBars(TaskPane).Visible=FalseEndSub批量清除软回车Sub批量清除软回车()'也可直接使用Alt+10或13替换Cells.ReplaceWhat:=Chr(10),Replacement:=,LookAt:=xlPart,SearchOrder:=_xlByRows,MatchCase:=False,SearchFormat:=False,ReplaceFormat:=FalseEndSub判断指定文件是否已经打开Sub判断指定文件是否已经打开()DimxAsIntegerForx=1ToWorkbooks.CountIfWorkbooks(x).Name=函数.xlsThen'文件名称MsgBox文件已打开ExitSubEndIfNextMsgBox文件未打开EndSub当前文件另存到指定目录Sub当前激活文件另存到指定目录()ActiveWorkbook.SaveAsFilename:=E:\信件\&ActiveWorkbook.NameEndSub另存指定文件名Sub另存指定文件名()ActiveWorkbook.SaveAsThisWorkbook.Path&\别名.xlsEndSub以本工作表名称另存文件到当前目录Sub以本工作表名称另存文件到当前目录()ActiveWorkbook.SaveAsFilename:=ThisWorkbook.Path&\&ActiveSheet.Name&.xlsEndSub将本工作表单独另存文件到Excel当前默认目录Sub将本工作表单独另存文件到Excel当前默认目录()ActiveSheet.CopyActiveWorkbook.SaveAsFilename:=ActiveSheet.Name&.xlsEndSub以活动工作表名称另存文件到Excel当前默认目录Sub以活动工作表名称另存文件到Excel当前默认目录()ActiveWorkbook.SaveAsFilename:=ActiveSheet.Name&.xls,FileFormat:=_xlNormal,Password:=,WriteResPassword:=,ReadOnlyRecommended:=False_,CreateBackup:=FalseEndSub另存所有工作表为工作簿Sub另存所有工作表为工作簿()DimshtAsWorksheetApplication.ScreenUpdating=Falseipath=ThisWorkbook.Path&\ForEachshtInSheetssht.CopyActiveWorkbook.SaveAsipath&sht.Name&.xls'(工作表名称为文件名）'ActiveWorkbook.SaveAsipath&sht.Name&Trim(sht.[d15])&.xls'（文件名称&D15单元内容）'ActiveWorkbook.SaveAsipath&Trim(sht.[d15])&.xls'（文件名称为D15单元内容）ActiveWorkbook.CloseNextApplication.ScreenUpdating=TrueEndSub以指定单元内容为新文件名另存文件Sub以指定单元内容为新文件名另存文件()ThisWorkbook.SaveAsFilename:=ThisWorkbook.Path&\&Sheet1.[A1]EndSub以当前日期为新文件名另存文件Sub以当前日期为新文件名另存文件()ThisWorkbook.SaveAsThisWorkbook.Path&\&Format(Now(),yyyymmdd)&.xlsEndSubSub以当前日期为名称另存文件()ActiveWorkbook.SaveAsFilename:=Date&.xlsEndSub以当前日期和时间为新文件名另存文件Sub以当前日期和时间为新文件名另存文件()ThisWorkbook.SaveAsThisWorkbook.Path&\&Format(Now(),yyyy&年&mm&月&dd&日&h&时&mm&分&ss&秒)&.xlsEndSub另存本表为TXT文件Sub另存本表为TXT文件()DimsAsStringDimFullNameAsString,rngAsRangeApplication.ScreenUpdating=FalseFullName=(ActiveSheet.Name&.txt)'以当前表名为TXT文件名'FullName=Replace(ThisWorkbook.FullName,.xls,.txt)'以当前文件名为TXT文件名'FullName=Replace(ThisWorkbook.FullName,.xls,ActiveSheet.Name&.txt)'以文件名&表名为TXT文件名OpenFullNameForOutputAs#1'以读写方式打开文件，每次写内容都会覆盖原先的内容'参考帮助，fullname为文件全名ForEachrngInRange(a1).CurrentRegions=s&IIf(s=,,|)&rng.ValueIfrng.Column=Range(a1).CurrentRegion.Columns.CountThenPrint#1,s&|'把数据写到文本文件里s=EndIfNextClose#1'关闭文件Application.ScreenUpdating=TrueMsgBox数据已导入文本EndSub引用指定位置单元内容为部分文件名另存文件Sub引用指定位置单元内容为部分文件名另存文件()ActiveWorkbook.SaveAsFilename:=E:\信件\&解答&Range(sheet1!a1)&郎雀.xlsEndSub将A列数据排序到D列Sub将A列数据排序到D列()[d:d]=[a:a].Value[d:d].SortKey1:=Range(D1),Order1:=xlAscending,Header:=xlYesEndSub将指定范围的数据排列到D列Sub将指定范围的数据排列到D列()Dimarr1,arr2,i%,xarr1=Range(A1:C3)ReDimarr2(1ToUBound(arr1,1)*UBound(arr1,2),1To1)ForEachxInApplication.Transpose(arr1)i=i+1arr2(i,1)=xNextxRange(D1).Resize(i,1)=arr2EndSub光标移动Sub光标移动()ActiveCell.Offset(1,2).Select'向下移动1行，向右移动2列EndSub光标所在行上移一行Sub光标所在行上移一行()Dimi%i=Split(ActiveCell.Address,$)(2)Ifi1ThenRows(i).CutRows(i-1).InsertShift:=xlDownEndIfEndSub加数据有效限制Sub加数据有效限制()WithSelection.Validation.Delete.AddType:=xlValidateList,AlertStyle:=xlValidAlertStop,Operator:=_xlBetween,Formula1:=[e-mail]=False.InCellDropdown=False.InputTitle=.ErrorTitle=.InputMessage=.ErrorMessage=要奋斗就会有牺牲，死人的事是经常发生的。.IMEMode=xlIMEModeNoControl.ShowInput=True.ShowError=TrueEndWithEndSub取消数据有效限制Sub取消数据有效限制()WithSelection.Validation.Delete.AddType:=xlValidateInputOnly,AlertStyle:=xlValidAlertStop,Operator_:=xlBetween.IgnoreBlank=False.InCellDropdown=False.InputTitle=.ErrorTitle=.InputMessage=.ErrorMessage=.IMEMode=xlIMEModeNoControl.ShowInput=True.ShowError=TrueEndWithEndSub重排窗口Sub重排窗口()Application.CommandBars(Web).Visible=FalseApplication.CommandBars(我的工具).Visible=FalseWindows.ArrangeArrangeStyle:=xlCascadeEndSub按当前单元文本选择打开指定文件单元Sub选择打开文件单元()Dimaa=ActiveCell.ValueRange(a).Worksheet.ActivateRange(a).SelectEndSub回车光标向右Sub录入光标向右()Application.MoveAfterReturnDirection=xlToRightEndSub回车光标向下Sub录入光标向下()Application.MoveAfterReturnDirection=xlDownEndSub保护工作表时取消选定锁定单元Sub取消选定锁定单元()ActiveSheet.EnableSelection=xlUnlockedCells'用于2000版EndSub保存并退出ExcelSub保存并退出Excel()Application.SendKeys({ENTER}{ENTER}%fx)ActiveWorkbook.SaveEndSub隐藏/显示指定列空值行Sub隐藏显示E列空值行()Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden=Not(Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden)EndSub深度隐藏指定工作表Sub深度隐藏指定工作表()Sheets(用户名密码).Visible=xlVeryHiddenEndSub隐藏指定工作表Sub隐藏指定工作表()Sheets(用户名密码).Visible=falseEndSub隐藏当前工作表Sub隐藏当前工作表()ActiveWindow.SelectedSheets.Visible=falseEndSub返回当前工作表名称Sub返回当前工作表名称()wsName=ActiveSheet.NameMsgBox当前工作表为：&wsNameEndSub获取上一次所进入工作簿的工作表名称Sub获取上一次所进入工作簿的工作表名称()MsgBoxWorkbooks(2).ActiveSheet.NameEndSub按光标选定颜色隐藏本列其他颜色行Sub按颜色筛选()'思路就是:其它背景色之行全部隐藏DimUseRow,AC,i'首先选择一个有颜色之单元格，然后动行宏，其它颜色所在行隐藏UseRow=Cells.SpecialCells(xlCellTypeLastCell).Row'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格IfActiveCell.RowUseRowThenMsgBox请在要筛选的区域选择一个有颜色之单元格！,vbExclamation,错误ElseAC=ActiveCell.ColumnCells.EntireRow.Hidden=False'显示所有行Fori=2ToUseRowIfCells(i,AC).Int