259个常用宏

提示确定或取消执行宏

Sub 提示确定或取消执行宏()

If vbOK = MsgBox("确定要复制吗?", vbOKCancel) Then

Range("A4:A14").Copy Range("b4:b14")

Msgbox "复制结束"

End If

End Sub

提示开始和结束

Sub 提示结束()

Msgbox "运行开始"

过程……

Msgbox "运行结束"

End Sub

拷贝指定表不相邻多列数据到新位置

Sub 拷贝指定表不相邻多列数据到新位置()

Sheets("sheet1").Range("A:A,J:J").Copy Range("d1")

End Sub

选择2至4行

Sub 选择2至4行()

    Dim a As Integer

    Dim b As Integer

    a = 2

    b = 4

    Rows(a & ":" & b).Select

End Sub

在当前选区有条件替换数值为文本

Sub 在当前选区有条件替换数值为文本()

For Each r In Selection

    If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y"

Next

End Sub

自动筛选全部显示指定列

Sub 自动筛选全部显示指定列()

Selection.AutoFilter Field:=1

Selection.AutoFilter Field:=2

Selection.AutoFilter Field:=3

Selection.AutoFilter Field:=4

Selection.AutoFilter Field:=5

Selection.AutoFilter Field:=6

End Sub

自动筛选第2列值为A的行

Sub 自动筛选第2列值为A的行()

[a1].AutoFilter 2, "a"

End Sub

取消自动筛选()

Sub 取消自动筛选()

ActiveSheet.AutoFilterMode = False

End Sub

全部显示指定表的自动筛选

Sub 全部显示指定表的自动筛选()

If Sheet1.FilterMode = True Then

   Sheet1.ShowAllData

End If

End Sub

强行合并单元

Sub 强行合并单元()

Application.DisplayAlerts = False '不出现对话框，按对话框默认选择

Range("a3:a4").Merge

Application.ScreenUpdating = True

End Sub

设置单元区域格式

Sub 设置单元区域格式()

[a:a].NumberFormat = "yyyy.mm.dd"

Sheet2.[B:B].NumberFormatLocal = "yyyy-m-d"

Sheet2.[C:C].NumberFormatLocal = "G/通用格式"

End Sub

在所有工作表的A1单元返回顺序号

Sub 在所有工作表的A1单元返回顺序号()

For i = 1 To Sheets.Count

Sheets(i).Cells(1, 1) = "'" & Application.WorksheetFunction.Text(0 + i, "000")

Next

End Sub

根据A1单元内容返回C1数值

Sub 根据A1单元内容返回C1数值()

If Range("A1") = "A" Then

    Range("C1").FormulaR1C1 = "结算"

      ElseIf Range("A1") = "B" Then

        Range("C1").FormulaR1C1 = "合计"

      ElseIf Range("A1") = "C" Then

    Range("C1").FormulaR1C1 = "部门"

   End If

End Sub

根据A1内容选择执行宏

Sub 根据A1内容选择执行宏()

    Select Case Sheet1.[A1]

    Case "A"

        宏1

    Case "B"

        宏2

    Case "C"

        宏3

    Case Else

    End Select

End Sub

删除A列空行

Sub 删除A列空行()

Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

在A列产生不重复随机数

Sub 在A列产生不重复随机数()

Randomize Timer

Dim c(100) As Byte

For i = 1 To 100 '产生100个随机数

c(i) = i

Next

k = 100

Do While l < 100

r = Int(Rnd() * k) + 1 '随机数的范围

aa = c(r)

c(r) = c(k)

c(k) = aa

k = k - 1

l = l + 1

Cells(l, 1) = aa

Loop

End Sub

将A列数据随机排列到F列

Sub 将A列数据随机排列到F列()

Dim n As Long

n = [a65536].End(xlUp).Row

[f1].Resize(n, 1) = [a1].Resize(n, 1).Value

[g1].Resize(n, 1) = "=rand()"

[f:g].Sort [g1]

[g:g] = ""

End Sub

取消选定区域的公式只保留值(假空转真空)

Sub 取消选定区域的公式只保留值()

'   Sheets("数据归并集中").Select   '指定工作表

'   Columns("Q:R").Select           '指定范围

Selection.Value = Selection.Value

End Sub

处理导入的显示为科学计数法样式的身份证号

Sub 处理导入的显示为科学计数法样式的身份证号()

Selection.Value = Selection.Formula

End Sub

返回指定单元的行高和列宽

Sub 返回指定单元的行高和列宽()

[c2] = Range("A1").ColumnWidth '列宽

[b2] = Range("A1").RowHeight    '行高

End Sub

Sub 返回指定单元的行高和列宽()

    Dim r%, c%

    r = [a1].RowHeight

    c = [a1].ColumnWidth

    [b2] = r '行高

    [c2] = c '列宽

End Sub

指定行高和列宽

Sub 指定行高和列宽()

Range("A1:F1").ColumnWidth = 10 '指定列宽

Range("A2:A10").RowHeight = 40   '指定行高

End Sub

Sub 指定行高和列宽()

Columns("A:F").ColumnWidth = 10 '指定列宽

Rows("2:10").RowHeight = 40      '指定行高

End Sub

指定单元的行高和列宽与A1单元相同

Sub 指定单元的行高和列宽与A1单元相同()

Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth '指定列宽

Range("A2:A10").RowHeight = Range("A1").RowHeight   '指定行高

End Sub

填公式

Sub 填公式()

Range("C2:C12").Value = "=SUM(A2:B2)"

End Sub

建立当前工作表的副本为001表

Sub 建立当前工作表的副本为001表()

    ActiveSheet.Copy Before:=Sheets(1)

    ActiveSheet.Name = "001"

End Sub

在第一个表前插入多工作表

Sub 在第一个表前插入多工作表()

Sheets(1).Select

For I = 1 To 50

Sheets.Add.Name = "新表" & I

Next

End Sub

清除A列再插入序号

Sub 清除A列再插入序号()

'Columns(1).ClearContents '清除A列内容

For i = 1 To 20

Range("a" & i) = i

Next

End Sub

反方向文本(自定义函数)

Function zhyz(zhyz1 As Range)

zhyz = StrReverse(zhyz1)

End Function

将代码复制到模块后单元公式：=zhyz(单元格)

指定选择单元区域弹出消息

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address = "$A$1:$C$3" Then

   MsgBox "你选择对了"

End If

End Sub

将B列数据添加超链接到K列

Sub 将B列数据添加超链接到K列()

    For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)

        ActiveSheet.Hyperlinks.Add Anchor:=Rng, Address:="", SubAddress:=Sheet1.Range("K" & Rng.Row).Address, ScreenTip:="点击转到:" & Sheet1.Name & "K" & Rng.Row

    Next

End Sub

删除B列数据的超链接

Sub 删除超链接()

    For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row)

        Sheet1.Range(Rng.Address).Hyperlinks.Delete

    Next

End Sub

分离临时表A列数据的文本和超链接并整理到数据库表

Sub 分离A列中的超链接到指定表的B和C列()

i = Worksheets("数据库").Range("b60000").End(xlUp).Row

For Each h In Worksheets("临时").Hyperlinks

Worksheets("数据库").Cells(i + 1, 2) = h.TextToDisplay

Worksheets("数据库").Cells(i + 1, 3) = h.Address

Range(Worksheets("数据库").Cells(i + 1, 3), Worksheets("数据库").Cells(i + 1, 3)).Hyperlinks.Add Anchor:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)

i = i + 1

Next

End Sub

分离临时表A列数据的文本和超链接并会同其他数据整理到数据库表

Sub 分离A列数据的文本和超链接并会同其他数据整理到指定表()

ier = Worksheets("数据库").Range("b60000").End(xlUp).Row

For ee = 5 To Range("a60000").End(xlUp).Row

For Each hh In Worksheets("临时").Hyperlinks

If hh.TextToDisplay = Cells(ee, 1) And Cells(ee, 1) <> "" Then

www = www & "," & ee

   End If

Next

Next

www = Right(www, Len(www) - 1)

zxc = Split(www, ",")

For sd = 0 To UBound(zxc) - 1

For wee = zxc(sd) + 1 To zxc(sd + 1) - 1

Worksheets("数据库").Cells(sdf + ier + 1, uu + 4) = Cells(wee, 1)

uu = uu + 1

Next

sdf = sdf + 1

uu = 0

Next

For Each hhh In Worksheets("临时").Range("A6:A6000").Hyperlinks

Worksheets("数据库").Cells(ier + 1, 2) = hhh.TextToDisplay

Worksheets("数据库").Cells(ier + 1, 3) = hhh.Address

Range(Worksheets("数据库").Cells(ier + 1, 3), Worksheets("数据库").Cells(ier + 1, 3)).Hyperlinks.Add Anchor:=Worksheets("数据库").Cells(ier + 1, 3), Address:=Worksheets("数据库").Cells(ier + 1, 3)

ier = ier + 1

Next

End Sub

返回A列最后一个非空单元行号

Sub 返回A列最后非空单元行号()

MsgBox Cells.Range("A65536").End(xlUp).Row

End Sub

返回表中第一个非空单元地址(行搜索)

Sub 返回表中第一个非空单元地址()

MsgBox Cells.Find("*").Address

End Sub

返回表中各非空单元区域地址(行搜索)

Sub 返回表中各非空单元区域地址()

MsgBox Cells.SpecialCells(2).Address

End Sub

返回第一个数值行号

Sub 返回第一个数值行号()

MsgBox [b:b].SpecialCells(2, 1).Row

End Sub

返回第1行最右边非空单元的列号

Sub 返回第1行最右边非空单元的列号()

X = [IV1].End(xlToLeft).Column

MsgBox X

End Sub

返回连续数值单元的数量

Sub 返回连续数值单元的数量()

MsgBox [b:b].SpecialCells(2, 1).Rows.Count

End Sub

统计指定范围和内容的单元数量

Sub 统计指定范围和内容的单元数量()

x = Application.WorksheetFunction.CountIf(Range("A3:B100"), "总计")

Range("B1") = x

End Sub

统计不同颜色的数字的和（自定义函数）

Public Function COLOR(ByVal X As Range, Y)

For Each I In X

    If I.Font.ColorIndex = Y Then

         COLOR = COLOR + I

    End If

Next I

End Function

'统计红色,输入：=COLOR(B2:B8,3)

'统计蓝色,输入：=COLOR(B2:B8,5)

返回非空单元数量

Sub 返回非空单元数量()

x = Application.CountA(Range("A1:Z65536"))

MsgBox x

End Sub

返回A列非空单元数量

Sub 返回A列非空单元数量()

y = Application.CountA(Columns(1))

MsgBox y

End Sub

返回圆周率π

Sub Macro1()

Range("A1") = Application.Pi()

End Sub

定义指定单元内容为页眉/页脚

Sub 定义指定单元内容为页眉/页脚()

BBB = Sheets("表1").Range("A2")

    With ActiveSheet.PageSetup

        .CenterHeader = BBB   '定义页眉

'       .CenterFooter = BBB   '定义页脚

    End With

End Sub

提示并全部清除当前选择区域

Sub 提示并全部清除当前选择区域()

If MsgBox("你确定要清除选择的区域吗?", vbYesNo, " 提示:") = vbYes Then Selection.Clear

End Sub

全部清除当前选择区域

Sub 全部清除当前选择区域()

Selection.Clear

' Range("A1:B10").Clear    '全部清除指定区域

End Sub

清除指定区域数值

Sub 清除单元数值()

Sheet1.[A1:A10].ClearContents

End Sub

Sub 清除指定区域数值()

    Range("A1:C8") = ClearContents

End Sub

Sub 清除指定区域数值()

    Sheet1.[A1:A10]=""

End Sub

对指定工作表执行取消隐藏》打印》隐藏工作表

Sub 打印隐藏工作表()

Sheets("报表1").Visible = 1

Sheets("报表1").PrintOut Copies:=1, Collate:=True

Sheets("报表1").Visible = 0

End Sub

打开文件时执行指定宏(工作簿代码)

Private Sub Workbook_Open()

重排窗口    '要执行的宏名称

End Sub

关闭文件时执行指定宏(工作簿代码)

Private Sub Workbook_BeforeClose(Cancel As Boolean)

重排窗口    '要执行的宏名称

End Sub

弹出提示A1单元内容

Sub 弹出提示A1单元内容()

MsgBox "提示" & Range("A1").Value

End Sub

延时15秒执行重排窗口宏

Sub 延时15秒重排窗口()

Application.OnTime Now + TimeValue("00:00:15"), "重排窗口"

End Sub

撤消工作表保护并取消密码

Sub 撤消工作表保护并取消密码()

ActiveSheet.Unprotect Password:=123456

End Sub

重算指定表

Sub 重算指定表()

Worksheets("传送参数").Calculate

Worksheets("目录").Calculate

End Sub

将第5行移到窗口的最上面

Worksheets("Sheet1").Activate

ActiveWindow.ScrollRow = 5

对第一张工作表的指定区域进行排序

Sub 对第一张工作表的指定区域进行排序()

    With Worksheets(1)

    .Range("a2:a100").Sort Key1:=.Range("a1")

    End With

End Sub

显示指定工作表的打印预览

Sub 显示指定工作表的打印预览()

Worksheets("Sheet1").PrintPreview

End Sub

用单元格A1的内容作为文件名另存当前工作簿

Sub b()

ActiveWorkbook.SaveCopyAs Range("A1") + ".xls"

End Sub

[禁用/启用]保存和另存的代码

Sub 禁用保存()

Application.CommandBars("File").Controls(4).Enabled = False

Application.CommandBars("File").Controls(5).Enabled = False

End Sub

Sub 启用保存()

Application.CommandBars("File").Controls(4).Enabled = True

Application.CommandBars("File").Controls(5).Enabled = True

End Sub

在A和B列返回当前选区的名称和公式

Sub 在A和B列返回当前选区的名称和公式()

[a1].ListNames

End Sub

朗读朗读A列,按ESC键中止

Sub 朗读A列()

    Dim myStr$, i&, tRng As Range

    Dim mySpk As Speech

    i = [A65536].End(xlUp).Row

    Set mySpk = Application.Speech

    myStr = Replace(Replace(Range("A1:A" & i).Address, "$", ""), ":", "到")

    On Error Resume Next

    With mySpk

           .Speak "_", , , False

        For Each tRng In Range("A1:A" & i)

            If Err.Number <> 0 Then .Speak "_", , , True: Exit Sub

            If Not tRng Is Nothing Then .Speak tRng, , , False

        Next

    End With

End Sub

朗读固定语句，请按ESC键终止

Sub 朗读固定语句()

    On Error Resume Next

        Application.Speech.Speak "你好，节日快乐。", , , False

    If Err.Number <> 0 Then

        Application.Speech.Speak "", , , True

    End If

End Sub

在M和N列的14行以下选择单元时显示调用日历控件（工作表代码）

Private Sub Calendar1_Click()

    With Calendar1

        ActiveCell = .Value

        .Visible = False

    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Column = 13 And Target.Row > 3 Or Target.Column = 14 And Target.Row > 3 Then

        If IsDate(Target) Then

           Calendar1.Value = Target

        Else

           Calendar1.Today

        End If

        Calendar1.Visible = -20

        Calendar1.Top = ActiveCell.Top + ActiveCell.Height

        Calendar1.Left = ActiveCell.Left + Cells(ActiveCell.Rows.Count, 1).Left

    Else

        Calendar1.Visible = 0

    End If

End Sub

'丢失复制功能

添加自定义序列

Sub 添加自定义序列()

    Application.AddCustomList ListArray:=Array("优","良", "中", "差"，"劣")

End Sub

弹出打印对话框

Sub 弹出打印对话框()

Application.Dialogs(xlDialogPrint).Show

End Sub

返回总页码

Sub 返回总页码()

    Dim a

    Sheet1.Activate

    a = ExecuteExcel4Macro("Get.Document(50)")

    Range("A1") = a

End Sub

合并各工作表内容

Sub 合并各工作表内容()

sp = InputBox("各表内容之间，间隔几行？不输则默认为0")

If sp = "" Then

sp = 0

End If

st = InputBox("各表从第几行开始合并？不输则默认为2")

If st = "" Then

   st = 2

End If

Sheets(1).Select

Sheets.Add

If st > 1 Then

    Sheets(2).Select

    Rows("1:" & CStr(st - 1)).Select

    Selection.Copy

    Sheets(1).Select

    Range("A1").Select

    ActiveSheet.Paste

y = st - 1

End If

For i = 2 To Sheets.Count

Sheets(i).Select

     For v = 1 To 256

        zd = Cells(65535, v).End(xlUp).Row

        If zd > x Then

           x = zd

        End If

     Next v

If y + x - st + 1 + sp > 65536 Then

MsgBox "内容太多，仅合并前" & i - 2 & "个表的内容，请把其它表复制到新工作薄里再用此程序合并！"

Else:

Rows(st & ":" & x).Select

Selection.Copy

Sheets(1).Select

Range("A" & CStr(y + 1)).Select

ActiveSheet.Paste

Sheets(i).Select

Range("A1").Select                        '取消单元格被全选状态。

Application.CutCopyMode = False           '忘掉复制的内容。

End If

y = y + x - st + 1 + sp

x = 0

Next i

Sheets(1).Select

Range("A1").Select                          '光标移至A1。

MsgBox "这就是合并后的表，请命名！"

End Sub

合并指定目录中所有文件中相同格式工作表的数据

Sub 合并数据()

   '合并指定目录中所有文件中相同格式工作表的数据

   '见http://club./dispbbs.asp?boardid=1&replyid=900613&id=249319&page=1&skin=0&Star=2帖11楼eq800的代码

   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer

   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动

   myPath = ThisWorkbook.Path & "\分表\"          '把文件路径定义给变量

  

   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件

   Do While myFile <> ""                     '当指定路径中有文件时进行循环

      If myFile <> ThisWorkbook.Name Then

         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件

          For i = 1 To AK.Sheets.Count

         aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row

         tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1

            'AK.Sheets(i).Select

         AK.Sheets(i).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow) '取得第3行以后的数据

         Next

         Workbooks(myFile).Close False               '关闭源工作簿,并不作修改

      End If

      myFile = Dir                                   '找寻下一个*.xls文件

   Loop

     

   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用

   MsgBox "汇总完成，请查看！", 64, "提示"

End Sub

隐藏指定工作表的指定列

Sub 隐藏指定工作表的指定列()

Sheet1.Columns("B:B").EntireColumn.Hidden = True

End Sub

把a列不重复值取到e列

Sub 把a列不重复值取到e列()

[A:A].AdvancedFilter 2, , [e1], 1

End Sub

当前选区的行列数

Sub 当前选区的行列数()

Range("A1") = Selection.Rows.Count      '当前选区的行数

Range("B1") = Selection.Columns.Count   '当前选区的列数

End Sub

单元格录入1位字符就跳转(工作表代码)

Private Sub TextBox1_Change()

If Len(Me.TextBox1.Text) <> 1 Then Exit Sub

Me.TextBox1.Activate

ActiveCell = Me.TextBox1.Text

Me.TextBox1.Text = ""

ActiveCell.Activate

Application.SendKeys "~"

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

With TextBox1

.Left = ActiveCell.Left

.Top = ActiveCell.Top

.Width = ActiveCell.Width

.Height = ActiveCell.Height

End With

Me.TextBox1.Activate

End SubSub

当指定日期（每月10日）打开文件执行宏

Sub auto_open()

If Day(Date) = 10 Then

重排窗口

End If

End Sub

提示并清空单元区域

Sub 清空单元区域()

If MsgBox("是否真的要清空数据?清除后将无法恢复", 1 + vbokNo) = vbOK Then

    Range("A1:B10,A15:B25").ClearContents

End If

End Sub

返回光标所在行号

Sub 返回光标所在行号()

Range("A1") = Selection.Row

End Sub

VBA返回公式结果

Sub VBA返回公式结果()

x = Application.WorksheetFunction.Sum(Range("a2:a100"))

Range("B1") = x

End Sub

按照当前行A列的图片名称插入图片到H列

Sub 按照当前行A列的图片名称插入图片到H列()

AAA = Selection.Row

    Range("H" & AAA).Select

    Selection.RowHeight = 37   '指定行高

    ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Range("A" & Selection.Row) & ".JPG").Select

    Selection.ShapeRange.LockAspectRatio = msoTrue

    Selection.ShapeRange.Height = 84.75

    Selection.ShapeRange.Width = 150.75

    Selection.ShapeRange.Rotation = 0#

    Selection.ShapeRange.ScaleWidth 0.73, msoFalse, msoScaleFromTopLeft

    Selection.ShapeRange.ScaleHeight 0.73, msoFalse, msoScaleFromTopLeft

    Selection.ShapeRange.ScaleHeight 0.24, msoFalse, msoScaleFromTopLeft

    Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft

    Range("H" & AAA).Select

End Sub

当前行下插入1行

Sub 当前行下插入1行()

Selection.Offset(1, 0).Insert

End Sub

取消指定行或列的隐藏

Sub 取消隐藏行()

    Rows("3:5").Select

    Selection.EntireRow.Hidden = False

End Sub

Sub 取消隐藏列()

    Columns("C:F").Select

    Selection.EntireColumn.Hidden = False

End Sub

复制单元格所在行

Sub 复制单元格所在行()

    Selection.EntireRow.Copy

End Sub

复制单元格所在列

Sub 复制单元格所在列()

    Selection.EntireColumn.Copy

End Sub

新建一个工作表

Sub 新建一个工作表()

    Sheets.Add

End Sub

新建一个工作簿

Sub 新建一个工作簿()

    Workbooks.Add

End Sub

选择多表为工作组

Sub 选择多表为工作组()

Dim Wks As Worksheet, shtCnt As Integer

Dim arr() As Variant, i As Integer, m As Integer, m1 As Integer, m2 As Integer

shtCnt = ThisWorkbook.Sheets.Count '取得工作表总数

ReDim arr(1 To shtCnt) '预定义数组

i = 0

m = 1 '循环的次数

m1 = 0 '找到起点循环的次数

m2 = 0 '找到终点循环的次数

For Each Wks In ThisWorkbook.Sheets '在所有工作表中循环

    If Wks.Name = "A2" Then   '工作组中第一个工作表名称

        i = i + 1

        arr(i) = Wks.Name '将工作表名称存进数组

        m1 = m

    End If

    If Wks.Name Like "A7" Then    '工作组中最后一个个工作表名称

        i = i + 1

        arr(i) = Wks.Name '将工作表名称存进数组

        m2 = m

        Exit For

    End If

    If i > 0 And m > m1 Then

        i = i + 1

        arr(i) = Wks.Name '将工作表名称存进数组

    End If

    m = m + 1

Next

If m2 > m1 Then '如果存在符合条件的工作表名称

    ReDim Preserve arr(1 To i) '重定义数组

    ThisWorkbook.Sheets(arr).Select '选中符合条件的所有工作表

End If

End Sub

在当前工作组各表中分别执行指定宏

'northwolves版主解答   http://club./dispbbs.asp?boardid=2&id=251426&star=2#914934

Sub 在当前工作组各表中分别执行指定宏()

Dim SH As Worksheet

For Each SH In ActiveWindow.SelectedSheets

SH.Activate

临时

Next

End Sub

    '临时宏中原录制代码ActiveWorkbook.Names.Add Name:="临时", RefersToR1C1:="=Sheet1!R1C1"      '插入名称准备返回使用

    '临时宏经修改后的代码ActiveWorkbook.names.Add Name:="临时", RefersToR1C1:="=" + ActiveSheet.Name + "!R1C1"     '插入名称准备返回使用

'冰山上的来客解答   http://club./dispbbs.asp?boardid=2&id=251426

'其中指定宏代码一定要避免执行工作表的Select方法

Dim SelShts As Sheets

Dim Sht As Worksheet

Sub 在当前工作组各表中分别执行指定宏()

    Set SelShts = ActiveWindow.SelectedSheets

    For Each Sht In SelShts

       Call 临时

    Next

End Sub

复制当前工作簿的报表到临时工作簿

Sub 复制当前工作簿的报表到临时工作簿()

'作者：yuanzhuping版主

Dim x As Integer

Dim sht As Worksheet

On Error Resume Next

For x = 1 To Workbooks.Count

    If Workbooks(x).Name = "临时.xls" Then

        For Each sht In Workbooks(x).Sheets

        If sht.Name = "001" Then

            MsgBox "已经有了001表", 64, "提示"

               

            Exit Sub

        End If

    Next

        Sheets("报表").Copy Before:=Workbooks("临时.xls").Sheets(1)

            ActiveSheet.Name = "001"

        Exit Sub

    End If

Next

    Workbooks.Add

    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "临时"

    ThisWorkbook.Activate

    Sheets("报表").Copy Before:=Workbooks("临时.xls").Sheets(1)

    ActiveSheet.Name = "001"

End Sub

需求说明：

'复制当前工作簿的“报表”工作表到“临时”工作簿为“001”表。

'如果“临时”工作簿未打开，就创建新工作簿为“临时”并在其中加入“001”表；

'如果“临时”工作簿已经打开，就直接加入“001”表。

'如果打开的“临时”工作簿中已经有“001”表，就报错退出。

'帖子地址：http://club./dispbbs.asp?boardid=2&replyid=875804&id=245219&page=1&skin=0&Star=2

删除指定文件

Sub 删除指定文件()

Kill "E:\信件\1.xls"

End Sub

合并A1至C1的内容写到D15单元的批注中

   ‘http://club./dispbbs.asp?boardid=2&id=251887 northwolves版主

Sub 将A1至C1的内容写到D15单元的批注中()

[iv1:iv12] = "=rc1 & "" ""& rc2 &"" ""& rc3"

[d15].AddComment Join(Application.Transpose([iv1:iv12]), vbCrLf)

[iv1:iv12] = ""

[d15].Comment.Visible = True

[d15].Comment.Shape.Height = 100

End Sub

自动重算

Sub 自动重算()

    With Application

        .Calculation = xlAutomatic

    End With

End Sub

手动重算

Sub 手动重算()

    With Application

        .Calculation = xlManual

    End With

End Sub