Excel常见宏(简洁版)(7)

MsgBox \对不起,您没有使用该宏的权限,按确定键后退出!\ End If End Sub

拷贝A1公式和格式到A2 Sub 拷贝A1公式到A2()

Workbooks(\临时表\表1\

Workbooks(\临时表\表2\End Sub

复制单元数值 Sub 复制数值()

s = Workbooks(\ Workbooks(\End Sub

插入数值条件格式

Sub 插入数值条件格式()

Selection.FormatConditions.Delete

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=\

Selection.FormatConditions(1).Interior.ColorIndex = 45

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _ Formula1:=\

Selection.FormatConditions(2).Interior.ColorIndex = 39

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:=\

Selection.FormatConditions(3).Interior.ColorIndex = 34 End Sub

插入透明批注

Sub 插入透明批注()

Selection.AddComment

Selection.Comment.Visible = False Dim XS As Worksheet

For i = 1 To ActiveSheet.Comments.Count

ActiveSheet.Comments(i).Text \透明批注\

ActiveSheet.Comments(i).Shape.Fill.Visible = msoFalse Next End Sub 添加文本

Sub 添加文本()

Selection = Selection + \\不可在数字后添加文本

'Selection = Workbooks(\临时表\表2\调用指定地址内容 End Sub 工作表标签排序

Sub 工作表标签排序()

Dim i As Long, j As Long, nums As Long, msg As Long

msg = MsgBox(\工作表按升序排列请选 '是[Y]'. \工作表按降序排列请选 '否[N]'\工作表排序\If msg = vbCancel Then Exit Sub nums = Sheets.Count

If msg = vbYes Then 'Sort ascending For i = 1 To nums For j = i To nums

If UCase(Sheets(j).Name) < UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i) End If Next j

Next i

Else 'Sort descending For i = 1 To nums

For j = i To nums

If UCase(Sheets(j).Name) > UCase(Sheets(i).Name) Then Sheets(j).Move Before:=Sheets(i) End If Next j Next i End If End Sub

定义指定工作表标签颜色

Sub 定义指定工作表标签颜色() Sheets(\End Sub

在目录表建立本工作簿中各表链接目录

Sub 在目录表建立本工作簿中各表链接目录() Dim s%, Rng As Range On Error Resume Next Sheets(\目录\ If Err = 0 Then

Sheets(\目录\ Else

Sheets.Add

ActiveSheet.Name = \目录\ End If

For i = 1 To Sheets.Count

If Sheets(i).Name <> \目录\ s = s + 1

Set Rng = Sheets(\目录\ Rng = Format(s, \

ActiveSheet.Hyperlinks.Add Rng, \ScreenTip:=Sheets(i).Name End If Next

Sheets(\目录\End Sub

建立工作表文本目录

Sub 建立工作表文本目录() Sheets.Add before:=Sheets(1) Sheets(1).Name = \目录\For i = 2 To Sheets.Count

Cells(i - 1, 1) = Sheets(i).Name

'Sheets(1).Hyperlinks.Add Cells(i - 1, 1), \ '添加超链接 Next End Sub

查另一文件的全部表名

Sub 查另一文件的全部表名() On Error Resume Next Dim i%

Dim sh As Worksheet

Application.ScreenUpdating = False

Workbooks.Open Filename:=ThisWorkbook.Path & \

Windows(\1.xls\ '当前文件名称 Sheets(\Sheet1\ '当前表名称

i = 1 '将表名称返回到第1行 For Each sh In Workbooks(\

Cells(i, 1) = sh.Name '将表名称返回到第1列 i = i + 1 '返回每个表名称向下移动1行 Next sh

Windows(\ '关闭对象文件 Application.ScreenUpdating = True End Sub

当前单元录入计算机名

Sub 当前单元录入计算机名()

Selection = Environ(\

'Selection = Workbooks(\临时表\表2\调用指定地址内容 End Sub

当前单元录入计算机用户名

Sub 当前单元录入计算机用户名() Selection = Environ(\

'Selection = Workbooks(\临时表\表2\调用指定地址内容 End Sub

返回当前单元地址

Sub 返回当前单元地址() d = ActiveCell.Address [A1] = d End Sub

不连续区域录入当前日期 Sub 区域录入当前日期()

Selection.FormulaR1C1 = Format(Now(), \ End Sub

不连续区域录入当前数字日期 Sub 区域录入当前数字日期()

Selection.FormulaR1C1 = Format(Now(), \End Sub

不连续区域录入当前日期和时间 Sub 区域录入当前日期和时间()

Selection.FormulaR1C1 = Format(Now(), \ End Sub

不连续区域录入对勾 Sub 批量录入对勾()

Selection.FormulaR1C1 = \ End Sub

不连续区域录入当前文件名 Sub 批量录入当前文件名()

Selection.FormulaR1C1 = ThisWorkbook.Name End Sub

不连续区域添加文本 Sub 批量添加文本() Dim s As Range

For Each s In Selection s = s & \文本内容\Next End Sub

不连续区域插入文本 Sub 批量插入文本()

Dim s As Range

For Each s In Selection s = \文本内容\Next End Sub

从指定位置向下同时录入多单元指定内容

Sub 从指定位置向下同时录入多单元指定内容() Dim arr

arr = Array(\

[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub

按aa工作表A列的内容排列工作表标签顺序

Sub 按aa工作表A列的内容排列工作表标签顺序() Dim I%, str1$ I = 1

Sheets(\

Do While Cells(I, 1).Value <> \ str1 = Trim(Cells(I, 1).Value) Sheets(str1).Select

Sheets(str1).Move after:=Sheets(I) I = I + 1

Sheets(\ Loop End Sub

以A1单元文本作表名插入工作表

Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add

ActiveSheet.Name = nm End Sub

删除全部未选定工作表

Sub 删除全部未选定工作表()

Dim sht As Worksheet, n As Integer, iFlag As Boolean Dim ShtName() As String

n = ActiveWindow.SelectedSheets.Count ReDim ShtName(1 To n) n = 1

For Each sht In ActiveWindow.SelectedSheets ShtName(n) = sht.Name n = n + 1 Next

Application.DisplayAlerts = False For Each sht In Sheets iFlag = False For i = 1 To n - 1

If ShtName(i) = sht.Name Then iFlag = True Exit For End If Next

If Not iFlag Then sht.Delete Next

Application.DisplayAlerts = True

End Sub

将所选区域文本插入新建文本框

Sub 将所选区域文本插入新建文本框() For Each rag In Selection n = n & rag.Value & Chr(10) Next

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + ActiveCell.Height, 250#, 100).Select Selection.Characters.Text = \问题：\

With Selection.Characters(Start:=1, Length:=3).Font .Name = \黑体\ .FontStyle = \常规\ .Size = 12 End With End Sub

批量插入地址批注

Sub 批量插入地址批注() On Error Resume Next Dim r As Range

If Selection.Cells.Count > 0 Then For Each r In Selection r.Comment.Delete r.AddComment

r.Comment.Visible = False

r.Comment.Text Text:=\本单元格：\Next End If End Sub

批量插入统一批注

Sub 批量插入统一批注()

Dim r As Range, msg As String

msg = InputBox(\请输入欲批量插入的批注\提示\随便输点什么吧\If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment

r.Comment.Visible = False r.Comment.Text Text:=msg Next End If End Sub

以A1单元内容批量插入批注

Sub 以A1单元内容批量插入批注() Dim r As Range

If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment

r.Comment.Visible = False

r.Comment.Text Text:=[a1].Text Next End If End Sub

不连续区域插入当前文件名和表名及地址 Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection