Excel常见宏命令详解

清除剪贴板

Sub 清除剪贴板()

    Application.CutCopyMode = False

    Application.CommandBars("Task Pane").Visible = False

End Sub

批量清除软回车

Sub 批量清除软回车()

      '也可直接使用Alt+10或13替换

    Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _

        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" Then    '文件名称

            MsgBox "文件已打开"

            Exit Sub

        End If

    Next

    MsgBox "文件未打开"

End Sub

当前文件另存到指定目录

Sub 当前激活文件另存到指定目录()

ActiveWorkbook.SaveAs Filename:="E:\信件\" & ActiveWorkbook.Name

End Sub

另存指定文件名

Sub 另存指定文件名()

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\别名.xls"

End Sub

以本工作表名称另存文件到当前目录

Sub 以本工作表名称另存文件到当前目录()

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls"

End Sub

将本工作表单独另存文件到Excel当前默认目录

Sub 将本工作表单独另存文件到Excel当前默认目录()

ActiveSheet.Copy

    ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls"

End Sub

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

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

    ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls", FileFormat:= _

        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _

        , 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 & ".xls" '(工作表名称为文件名）

   'ActiveWorkbook.SaveAs ipath & sht.Name & Trim(sht.[d15]) & ".xls" '（文件名称 & D15单元内容）

   'ActiveWorkbook.SaveAs ipath & Trim(sht.[d15]) & ".xls"   '（文件名称为D15单元内容）

   ActiveWorkbook.Close

Next

Application.ScreenUpdating = True

End Sub

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

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

ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1]

End Sub

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

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

ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls"

End Sub

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

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 String

    Dim FullName As String, rng As Range

    Application.ScreenUpdating = False

     FullName = (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").CurrentRegion

        s = s & IIf(s = "", "", "|") & rng.Value

        If rng.Column = Range("a1").CurrentRegion.Columns.Count Then

            Print #1, s & "|" '把数据写到文本文件里

            s = ""

        End If

    Next

    Close #1   '关闭文件

    Application.ScreenUpdating = True

    MsgBox "数据已导入文本"

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:=xlYes

End Sub

将指定范围的数据排列到D列

Sub 将指定范围的数据排列到D列()

Dim arr1, arr2, i%, x

arr1 = 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 + 1

arr2(i, 1) = x

Next x

Range("D1").Resize(i, 1) = arr2

End Sub

光标移动

Sub 光标移动()

ActiveCell.Offset(1, 2).Select   '向下移动1行，向右移动2列

End Sub

光标所在行上移一行

Sub 光标所在行上移一行()

    Dim i%

    i = Split(ActiveCell.Address, "$")(2)

    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:="[e-mail]"

        .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