259個常用宏，免費查看。也在下載收藏……
望版主給加精，謝謝！


打開全部隱藏工作表
Sub 打開全部隱藏工作表()
Dim i As Integer
For i = 1 To Sheets.Count
Sheets(i).Visible = True
Next i
End Sub

循環(huán)宏
Sub 循環(huán)()
AAA = Range("C2")

Dim i As Long
Dim times As Long
times = AAA
'times代表循環(huán)次數(shù)，執(zhí)行前把times賦值即可(不可小于1，不可大于2147483647)
For i = 1 To times
Call 過濾一行

If Range("完成標志") = "完成" Then Exit For '如果名為'完成標志'的命名單元的值等于'完成',則退出循環(huán),如果一開始就等于'完成',則只執(zhí)行一次循環(huán)就退出
'If Sheets("傳送參數(shù)").Range("A" & i).Text = "完成" Then Exit For '如果某列出現(xiàn)"完成"內(nèi)容則退出循環(huán)
Next i
End Sub

錄制宏時調(diào)用“停止錄制”工具欄
Sub 錄制宏時調(diào)用停止錄制工具欄()
Application.CommandBars("Stop Recording").Visible = True
End Sub

高級篩選5列不重復數(shù)據(jù)至指定表
Sub 高級篩選5列不重復數(shù)據(jù)至Sheet2()
Sheets("Sheet2").Range("A1:E65536") = "" '清除Sheet2的A列
Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _
"A1"), Unique:=True
Sheet2.Columns("A:E").Sort Key1:=Sheet2.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin
End Sub

雙擊單元執(zhí)行宏(工作表代碼)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Range("$A$1") = "關閉" Then Exit Sub
Select Case Target.Address
Case "$A$4"
Call 宏1
Cancel = True
Case "$B$4"
Call 宏2
Cancel = True
Case "$C$4"
Call 宏3
Cancel = True
Case "$E$4"
Call 宏4
Cancel = True
End Select
End Sub

雙擊指定區(qū)域單元執(zhí)行宏(工作表代碼)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Range("$A$1") = "關閉" Then Exit Sub
If Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then Call 打開隱藏表
End Sub

進入單元執(zhí)行宏(工作表代碼)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'以單元格進入代替按鈕對象調(diào)用宏
If Range("$A$1") = "關閉" Then Exit Sub
Select Case Target.Address
Case "$A$5" '單元地址(Target.Address),或命名單元名字(Target.Name)
Call 宏1
Case "$B$5"
Call 宏2
Case "$C$5"
Call 宏3
End Select
End Sub

進入指定區(qū)域單元執(zhí)行宏(工作表代碼)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("$A$1") = "關閉" Then Exit Sub
If Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call 打開隱藏表
End Sub

在多個宏中依次循環(huán)執(zhí)行一個（控件按鈕代碼）
Private Sub CommandButton1_Click()
Static RunMacro As Integer
Select Case RunMacro
Case 0
宏1
RunMacro = 1
Case 1
宏2
RunMacro = 2
Case 2
宏3
RunMacro = 0
End Select
End Sub

在兩個宏中依次循環(huán)執(zhí)行一個并相應修改按鈕名稱（控件按鈕代碼）
Private Sub CommandButton1_Click()
With CommandButton1
If .Caption = "保護工作表" Then
Call 保護工作表
.Caption = "取消工作表保護"
Exit Sub
End If
If .Caption = "取消工作表保護" Then
Call 取消工作表保護
.Caption = "保護工作表"
Exit Sub
End If
End With
End Sub

在三個宏中依次循環(huán)執(zhí)行一個并相應修改按鈕名稱（控件按鈕代碼）
Option Explicit
Private Sub CommandButton1_Click()
With CommandButton1
If .Caption = "宏1" Then
Call 宏1
.Caption = "宏2"
Exit Sub
End If
If .Caption = "宏2" Then
Call 宏2
.Caption = "宏3"
Exit Sub
End If
If .Caption = "宏3" Then
Call 宏3
.Caption = "宏1"
Exit Sub
End If
End With
End Sub

根據(jù)A1單元文本隱藏/顯示按鈕（控件按鈕代碼）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("A1") > 2 Then
CommandButton1.Visible = 1
Else
CommandButton1.Visible = 0
End If
End Sub
Private Sub CommandButton1_Click()
重排窗口
End Sub

當前單元返回按鈕名稱（控件按鈕代碼）
Private Sub CommandButton1_Click()
ActiveCell = CommandButton1.Caption
End Sub

當前單元內(nèi)容返回到按鈕名稱（控件按鈕代碼）
Private Sub CommandButton1_Click()
CommandButton1.Caption = ActiveCell
End Sub


奇偶頁分別打印
Sub 奇偶頁分別打印()
Dim i%, Ps%
Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '總頁數(shù)
MsgBox "現(xiàn)在打印奇數(shù)頁,按確定開始."
For i = 1 To Ps Step 2
ActiveSheet.PrintOut from:=i, To:=i
Next i
MsgBox "現(xiàn)在打印偶數(shù)頁,按確定開始."
For i = 2 To Ps Step 2
ActiveSheet.PrintOut from:=i, To:=i
Next i
End Sub

自動打印多工作表第一頁
Sub 自動打印多工作表第一頁()
Dim sh As Integer
Dim x
Dim y
Dim sy
Dim syz
x = InputBox("請輸入起始工作表名字:")
sy = InputBox("請輸入結束工作表名字:")
y = Sheets(x).Index
syz = Sheets(sy).Index
For sh = y To syz
Sheets(sh).Select
Sheets(sh).PrintOut from:=1, To:=1
Next sh
End Sub

查找A列文本循環(huán)插入分頁符
Sub 循環(huán)插入分頁符()
' Selection = Workbooks("臨時表").Sheets("表2").Range("A1") 調(diào)用指定地址內(nèi)容

Dim i As Long
Dim times As Long
times = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分頁")
'times代表循環(huán)次數(shù)，執(zhí)行前把times賦值即可(不可小于1，不可大于2147483647)
For i = 1 To times
Call 插入分頁符
Next i
End Sub

Sub 插入分頁符()
Cells.Find(What:="分頁", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End Sub

Sub 取消原分頁()
Cells.Select
ActiveSheet.ResetAllPageBreaks
End Sub

將A列最后數(shù)據(jù)行以上的所有B列圖片大小調(diào)整為所在單元大小
Sub 將A列最后數(shù)據(jù)行以上的所有B列圖片大小調(diào)整為所在單元大小()
Dim Pic As Picture, i&
i = [A65536].End(xlUp).Row
For Each Pic In Sheet1.Pictures
If Not Application.Intersect(Pic.TopLeftCell, Range("B1:B" & i)) Is Nothing Then
Pic.Top = Pic.TopLeftCell.Top
Pic.Left = Pic.TopLeftCell.Left
Pic.Height = Pic.TopLeftCell.Height
Pic.Width = Pic.TopLeftCell.Width
End If
Next
End Sub

返回光標所在行數(shù)
Sub 返回光標所在行數(shù)()
x = ActiveCell.Row
Range("A1") = x
End Sub

在A1返回當前選中單元格數(shù)量
Sub 在A1返回當前選中單元格數(shù)量()
[A1] = Selection.Count
End Sub

返回當前工作簿中工作表數(shù)量
Sub 返回當前工作簿中工作表數(shù)量()
t = Application.Sheets.Count
MsgBox t
End Sub

返回光標選擇區(qū)域的行數(shù)和列數(shù)
Sub 返回光標選擇區(qū)域的行數(shù)和列數(shù)()
x = Selection.Rows.Count
y = Selection.Columns.Count
Range("A1") = x
Range("A2") = y
End Sub

工作表中包含數(shù)據(jù)的最大行數(shù)
Sub 包含數(shù)據(jù)的最大行數(shù)()
n = Cells.Find("*", , , , 1, 2).Row
MsgBox n
End Sub

返回A列數(shù)據(jù)的最大行數(shù)
Sub 返回A列數(shù)據(jù)的最大行數(shù)()
n = Range("a65536").End(xlUp).Row
Range("B1") = n
End Sub

將所選區(qū)域文本插入新建文本框
Sub 將所選區(qū)域文本插入新建文本框()
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 = "問題：" & n
With Selection.Characters(Start:=1, Length:=3).Font
.Name = "黑體"
.FontStyle = "常規(guī)"
.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:="本單元格：" & r.Address & " of " & Selection.Address
Next
End If
End Sub

批量插入統(tǒng)一批注
Sub 批量插入統(tǒng)一批注()
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單元內(nèi)容批量插入批注
Sub 以A1單元內(nèi)容批量插入批注()
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

不連續(xù)區(qū)域插入當前文件名和表名及地址
Sub 批量插入當前文件名和表名及地址()
For Each mycell In Selection
mycell.FormulaR1C1 = "[" + ActiveWorkbook.Name + "]" + ActiveSheet.Name + "!" + mycell.Address
Next
End Sub

不連續(xù)區(qū)域錄入當前單元地址
Sub 區(qū)域錄入當前單元地址()
For Each mycell In Selection
mycell.FormulaR1C1 = mycell.Address
Next
End Sub

連續(xù)區(qū)域錄入當前單元地址
Sub 連續(xù)區(qū)域錄入當前單元地址()
Selection = "=ADDRESS(ROW(),COLUMN(),4,1)"
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

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

不連續(xù)區(qū)域錄入當前日期
Sub 區(qū)域錄入當前日期()
Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d")
End Sub

不連續(xù)區(qū)域錄入當前數(shù)字日期
Sub 區(qū)域錄入當前數(shù)字日期()
Selection.FormulaR1C1 = Format(Now(), "yyyymmdd")
End Sub

不連續(xù)區(qū)域錄入當前日期和時間
Sub 區(qū)域錄入當前日期和時間()
Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss")
End Sub

不連續(xù)區(qū)域錄入對勾
Sub 批量錄入對勾()
Selection.FormulaR1C1 = "√"
End Sub

不連續(xù)區(qū)域錄入當前文件名
Sub 批量錄入當前文件名()
Selection.FormulaR1C1 = ThisWorkbook.Name
End Sub

不連續(xù)區(qū)域添加文本
Sub 批量添加文本()
Dim s As Range
For Each s In Selection
s = s & "文本內(nèi)容"
Next
End Sub

不連續(xù)區(qū)域插入文本
Sub 批量插入文本()
Dim s As Range
For Each s In Selection
s = "文本內(nèi)容" & s
Next
End Sub

從指定位置向下同時錄入多單元指定內(nèi)容
Sub 從指定位置向下同時錄入多單元指定內(nèi)容()
Dim arr
arr = Array("1", "2", "13", "25", "46", "12", "0", "20")
[B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr)
End Sub

按aa工作表A列的內(nèi)容排列工作表標簽順序
Sub 按aa工作表A列的內(nèi)容排列工作表標簽順序()
Dim I%, str1$

I = 1
Sheets("aa").Select
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("aa").Select

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 工作表標簽排序()
Dim i As Long, j As Long, nums As Long, msg As Long

msg = MsgBox("工作表按升序排列請選 '是[Y]'. " & vbCrLf & vbCrLf & "工作表按降序排列請選 '否[N]'", vbYesNoCancel, "工作表排序")

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

[ 本帖最后由 seawolf.deng 于 2008-5-17 00:52 編輯 ]