.Size = 12 End With End Sub
26：批量插入地址批注
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
27：批量插入统一批注
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
28：以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
29：不连续区域插入当前文件名和表名及地址
Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection
mycell.FormulaR1C1 = \mycell.Address Next End Sub
30：不连续区域录入当前单元地址
Sub 区域录入当前单元地址() For Each mycell In Selection
mycell.FormulaR1C1 = mycell.Address Next End Sub
31：连续区域录入当前单元地址
Sub 连续区域录入当前单元地址()
Selection = \ Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub
32：返回当前单元地址
Sub 返回当前单元地址() d = ActiveCell.Address [A1] = d End Sub
33：不连续区域录入当前日期
Sub 区域录入当前日期()
Selection.FormulaR1C1 = Format(Now(), \End Sub
34：不连续区域录入当前数字日期
Sub 区域录入当前数字日期()
Selection.FormulaR1C1 = Format(Now(), \End Sub
35：不连续区域录入当前日期和时间
Sub 区域录入当前日期和时间()
Selection.FormulaR1C1 = Format(Now(), \End Sub
36：不连续区域录入对勾
Sub 批量录入对勾()
Selection.FormulaR1C1 = \ End Sub
37：不连续区域录入当前文件名
Sub 批量录入当前文件名()
Selection.FormulaR1C1 = ThisWorkbook.Name End Sub
38：不连续区域添加文本
Sub 批量添加文本() Dim s As Range
For Each s In Selection s = s & \文本内容\ Next End Sub
39：不连续区域插入文本
Sub 批量插入文本() Dim s As Range
For Each s In Selection s = \文本内容\ Next End Sub
40：从指定位置向下同时录入多单元指定内容
Sub 从指定位置向下同时录入多单元指定内容() Dim arr
arr = Array(\
[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub
41：按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
42：以A1单元文本作表名插入工作表
Sub 以A1单元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add
ActiveSheet.Name = nm End Sub
43：删除所有未选定工作表
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
44：工作表标签排序
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