excel常用宏集合(8)

Application.CommandBars(\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 & \End Sub

129：以活动工作表名称另存文件到Excel当前默认目录

Sub 以活动工作表名称另存文件到Excel当前默认目录()

ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & \

xlNormal, Password:=\ , CreateBackup:=False End Sub

130：另存所有工作表为工作簿

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

131：以指定单元内容为新文件名另存文件

Sub 以指定单元内容为新文件名另存文件()

ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & \End Sub

132：以当前日期为新文件名另存文件

Sub 以当前日期为新文件名另存文件()

ThisWorkbook.SaveAs ThisWorkbook.Path & \End Sub

Sub 以当前日期为名称另存文件()

ActiveWorkbook.SaveAs Filename:=Date & \End Sub

133：以当前日期和时间为新文件名另存文件

Sub 以当前日期和时间为新文件名另存文件()

ThisWorkbook.SaveAs ThisWorkbook.Path & \年\月\日\时\分\秒\End Sub

134：另存本表为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

135：引用指定位置单元内容为部分文件名另存文件

Sub 引用指定位置单元内容为部分文件名另存文件()

ActiveWorkbook.SaveAs Filename:=\信件\\\解答\郎雀.xls\End Sub

136：将A列数据排序到D列

Sub 将A列数据排序到D列() [d:d] = [a:a].Value

[d:d].Sort Key1:=Range(\End Sub

137：将指定范围的数据排列到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

138：光标所在行上移一行

Sub 光标所在行上移一行() Dim i%

i = Split(ActiveCell.Address, \ If i > 1 Then Rows(i).Cut

Rows(i - 1).Insert Shift:=xlDown

End If End Sub

139：加数据有效限制

Sub 加数据有效限制()

With Selection.Validation .Delete

.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=\ .IgnoreBlank = False .InCellDropdown = False .InputTitle = \ .ErrorTitle = \ .InputMessage = \

.ErrorMessage = \要奋斗就会有牺牲，死人的事是经常发生的。\ .IMEMode = xlIMEModeNoControl .ShowInput = True .ShowError = True End With End Sub

140：取消数据有效限制

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