excel常用宏集合

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

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

259个常用宏-excelhome(2) 2009-08-15 14:11:45

45：定义指定工作表标签颜色

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

Sheets(\End Sub

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

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(\目录\