提示確定或取消執(zhí)行宏

Sub 提示確定或取消執(zhí)行宏()

If vbOK = MsgBox("確定要復(fù)制嗎?", vbOKCancel) Then

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

Msgbox "復(fù)制結(jié)束"

End If

End Sub

提示開始和結(jié)束

Sub 提示結(jié)束()

Msgbox "運行開始"

過程……

Msgbox "運行結(jié)束"

End Sub

拷貝指定表不相鄰多列數(shù)據(jù)到新位置

Sub 拷貝指定表不相鄰多列數(shù)據(jù)到新位置()

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

在當(dāng)前選區(qū)有條件替換數(shù)值為文本

Sub 在當(dāng)前選區(qū)有條件替換數(shù)值為文本()

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 '不出現(xiàn)對話框，按對話框默認選擇

Range("a3:a4").Merge

Application.ScreenUpdating = True

End Sub

設(shè)置單元區(qū)域格式

Sub 設(shè)置單元區(qū)域格式()

[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

根據(jù)A1單元內(nèi)容返回C1數(shù)值

Sub 根據(jù)A1單元內(nèi)容返回C1數(shù)值()

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

    Range("C1").FormulaR1C1 = "結(jié)算"

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

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

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

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

   End If

End Sub

根據(jù)A1內(nèi)容選擇執(zhí)行宏

Sub 根據(jù)A1內(nèi)容選擇執(zhí)行宏()

    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列產(chǎn)生不重復(fù)隨機數(shù)

Sub 在A列產(chǎn)生不重復(fù)隨機數(shù)()

Randomize Timer

Dim c(100) As Byte

For i = 1 To 100 '產(chǎn)生100個隨機數(shù)

c(i) = i

Next

k = 100

Do While l < 100

r = Int(Rnd() * k) + 1 '隨機數(shù)的范圍

aa = c(r)

c(r) = c(k)

c(k) = aa

k = k - 1

l = l + 1

Cells(l, 1) = aa

Loop

End Sub

將A列數(shù)據(jù)隨機排列到F列

Sub 將A列數(shù)據(jù)隨機排列到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

取消選定區(qū)域的公式只保留值(假空轉(zhuǎn)真空)

Sub 取消選定區(qū)域的公式只保留值()

'   Sheets("數(shù)據(jù)歸并集中").Select   '指定工作表

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

Selection.Value = Selection.Value

End Sub

處理導(dǎo)入的顯示為科學(xué)計數(shù)法樣式的身份證號

Sub 處理導(dǎo)入的顯示為科學(xué)計數(shù)法樣式的身份證號()

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

建立當(dāng)前工作表的副本為001表

Sub 建立當(dāng)前工作表的副本為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列內(nèi)容

For i = 1 To 20

Range("a" & i) = i

Next

End Sub

反方向文本(自定義函數(shù))

Function zhyz(zhyz1 As Range)

zhyz = StrReverse(zhyz1)

End Function

將代碼復(fù)制到模塊后單元公式：=zhyz(單元格)

指定選擇單元區(qū)域彈出消息

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

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

   MsgBox "你選擇對了"

End If

End Sub

將B列數(shù)據(jù)添加超鏈接到K列

Sub 將B列數(shù)據(jù)添加超鏈接到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:="點擊轉(zhuǎn)到:" & Sheet1.Name & "K" & Rng.Row

    Next

End Sub

刪除B列數(shù)據(jù)的超鏈接

Sub 刪除超鏈接()

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

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

    Next

End Sub

分離臨時表A列數(shù)據(jù)的文本和超鏈接并整理到數(shù)據(jù)庫表

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

i = Worksheets("數(shù)據(jù)庫").Range("b60000").End(xlUp).Row

For Each h In Worksheets("臨時").Hyperlinks

Worksheets("數(shù)據(jù)庫").Cells(i + 1, 2) = h.TextToDisplay

Worksheets("數(shù)據(jù)庫").Cells(i + 1, 3) = h.Address

Range(Worksheets("數(shù)據(jù)庫").Cells(i + 1, 3), Worksheets("數(shù)據(jù)庫").Cells(i + 1, 3)).Hyperlinks.Add Anchor:=Cells(i + 1, 3), Address:=Cells(i + 1, 3)

i = i + 1

Next

End Sub

分離臨時表A列數(shù)據(jù)的文本和超鏈接并會同其他數(shù)據(jù)整理到數(shù)據(jù)庫表

Sub 分離A列數(shù)據(jù)的文本和超鏈接并會同其他數(shù)據(jù)整理到指定表()

ier = Worksheets("數(shù)據(jù)庫").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("數(shù)據(jù)庫").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("數(shù)據(jù)庫").Cells(ier + 1, 2) = hhh.TextToDisplay

Worksheets("數(shù)據(jù)庫").Cells(ier + 1, 3) = hhh.Address

Range(Worksheets("數(shù)據(jù)庫").Cells(ier + 1, 3), Worksheets("數(shù)據(jù)庫").Cells(ier + 1, 3)).Hyperlinks.Add Anchor:=Worksheets("數(shù)據(jù)庫").Cells(ier + 1, 3), Address:=Worksheets("數(shù)據(jù)庫").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

返回表中各非空單元區(qū)域地址(行搜索)

Sub 返回表中各非空單元區(qū)域地址()

MsgBox Cells.SpecialCells(2).Address

End Sub

返回第一個數(shù)值行號

Sub 返回第一個數(shù)值行號()

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

End Sub

返回第1行最右邊非空單元的列號

Sub 返回第1行最右邊非空單元的列號()

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

MsgBox X

End Sub

返回連續(xù)數(shù)值單元的數(shù)量

Sub 返回連續(xù)數(shù)值單元的數(shù)量()

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

End Sub

統(tǒng)計指定范圍和內(nèi)容的單元數(shù)量

Sub 統(tǒng)計指定范圍和內(nèi)容的單元數(shù)量()

x = Application.WorksheetFunction.CountIf(Range("A3:B100"), "總計")

Range("B1") = x

End Sub

統(tǒng)計不同顏色的數(shù)字的和（自定義函數(shù)）

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

'統(tǒng)計紅色,輸入：=COLOR(B2:B8,3)

'統(tǒng)計藍色,輸入：=COLOR(B2:B8,5)

返回非空單元數(shù)量

Sub 返回非空單元數(shù)量()

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

MsgBox x

End Sub

返回A列非空單元數(shù)量

Sub 返回A列非空單元數(shù)量()

y = Application.CountA(Columns(1))

MsgBox y

End Sub

返回圓周率π

Sub Macro1()

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

End Sub

定義指定單元內(nèi)容為頁眉/頁腳

Sub 定義指定單元內(nèi)容為頁眉/頁腳()

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

    With ActiveSheet.PageSetup

        .CenterHeader = BBB   '定義頁眉

'       .CenterFooter = BBB   '定義頁腳

    End With

End Sub

提示并全部清除當(dāng)前選擇區(qū)域

Sub 提示并全部清除當(dāng)前選擇區(qū)域()

If MsgBox("你確定要清除選擇的區(qū)域嗎?", vbYesNo, " 提示:") = vbYes Then Selection.Clear

End Sub

全部清除當(dāng)前選擇區(qū)域

Sub 全部清除當(dāng)前選擇區(qū)域()

Selection.Clear

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

End Sub

清除指定區(qū)域數(shù)值

Sub 清除單元數(shù)值()

Sheet1.[A1:A10].ClearContents

End Sub

Sub 清除指定區(qū)域數(shù)值()

    Range("A1:C8") = ClearContents

End Sub

Sub 清除指定區(qū)域數(shù)值()

    Sheet1.[A1:A10]=""

End Sub

對指定工作表執(zhí)行取消隱藏》打印》隱藏工作表

Sub 打印隱藏工作表()

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

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

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

End Sub

打開文件時執(zhí)行指定宏(工作簿代碼)

Private Sub Workbook_Open()

重排窗口    '要執(zhí)行的宏名稱

End Sub

關(guān)閉文件時執(zhí)行指定宏(工作簿代碼)

Private Sub Workbook_BeforeClose(Cancel As Boolean)

重排窗口    '要執(zhí)行的宏名稱

End Sub

彈出提示A1單元內(nèi)容

Sub 彈出提示A1單元內(nèi)容()

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

End Sub

延時15秒執(zhí)行重排窗口宏

Sub 延時15秒重排窗口()

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

End Sub

撤消工作表保護并取消密碼

Sub 撤消工作表保護并取消密碼()

ActiveSheet.Unprotect Password:=123456

End Sub

重算指定表

Sub 重算指定表()

Worksheets("傳送參數(shù)").Calculate

Worksheets("目錄").Calculate

End Sub

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

Worksheets("Sheet1").Activate

ActiveWindow.ScrollRow = 5

對第一張工作表的指定區(qū)域進行排序

Sub 對第一張工作表的指定區(qū)域進行排序()

    With Worksheets(1)

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

    End With

End Sub

顯示指定工作表的打印預(yù)覽

Sub 顯示指定工作表的打印預(yù)覽()

Worksheets("Sheet1").PrintPreview

End Sub

用單元格A1的內(nèi)容作為文件名另存當(dāng)前工作簿

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列返回當(dāng)前選區(qū)的名稱和公式

Sub 在A和B列返回當(dāng)前選區(qū)的名稱和公式()

[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 "你好，節(jié)日快樂。", , , False

    If Err.Number <> 0 Then

        Application.Speech.Speak "", , , True

    End If

End Sub

在M和N列的14行以下選擇單元時顯示調(diào)用日歷控件（工作表代碼）

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

'丟失復(fù)制功能

添加自定義序列

Sub 添加自定義序列()

    Application.AddCustomList ListArray:=Array("優(yōu)","良", "中", "差"，"劣")

End Sub

彈出打印對話框

Sub 彈出打印對話框()

Application.Dialogs(xlDialogPrint).Show

End Sub

返回總頁碼

Sub 返回總頁碼()

    Dim a

    Sheet1.Activate

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

    Range("A1") = a

End Sub

合并各工作表內(nèi)容

Sub 合并各工作表內(nèi)容()

sp = InputBox("各表內(nèi)容之間，間隔幾行？不輸則默認為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 "內(nèi)容太多，僅合并前" & i - 2 & "個表的內(nèi)容，請把其它表復(fù)制到新工作薄里再用此程序合并！"

Else:

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

Selection.Copy

Sheets(1).Select

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

ActiveSheet.Paste

Sheets(i).Select

Range("A1").Select                        '取消單元格被全選狀態(tài)。

Application.CutCopyMode = False           '忘掉復(fù)制的內(nèi)容。

End If

y = y + x - st + 1 + sp

x = 0

Next i

Sheets(1).Select

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

MsgBox "這就是合并后的表，請命名！"

End Sub

合并指定目錄中所有文件中相同格式工作表的數(shù)據(jù)

Sub 合并數(shù)據(jù)()

   '合并指定目錄中所有文件中相同格式工作表的數(shù)據(jù)

   '見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        '凍結(jié)屏幕，以防屏幕抖動

   myPath = ThisWorkbook.Path & "\分表\"          '把文件路徑定義給變量

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

   Do While myFile <> ""                     '當(dāng)指定路徑中有文件時進行循環(huán)

      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行以后的數(shù)據(jù)

         Next

         Workbooks(myFile).Close False               '關(guān)閉源工作簿,并不作修改

      End If

      myFile = Dir                                   '找尋下一個*.xls文件

   Loop

   Application.ScreenUpdating = True                 '凍結(jié)屏幕,此類語句一般成對使用

   MsgBox "匯總完成，請查看！", 64, "提示"

End Sub

隱藏指定工作表的指定列

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

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

End Sub

把a列不重復(fù)值取到e列

Sub 把a列不重復(fù)值取到e列()

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

End Sub

當(dāng)前選區(qū)的行列數(shù)

Sub 當(dāng)前選區(qū)的行列數(shù)()

Range("A1") = Selection.Rows.Count      '當(dāng)前選區(qū)的行數(shù)

Range("B1") = Selection.Columns.Count   '當(dāng)前選區(qū)的列數(shù)

End Sub

單元格錄入1位字符就跳轉(zhuǎn)(工作表代碼)

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

當(dāng)指定日期（每月10日）打開文件執(zhí)行宏

Sub auto_open()

If Day(Date) = 10 Then

重排窗口

End If

End Sub

提示并清空單元區(qū)域

Sub 清空單元區(qū)域()

If MsgBox("是否真的要清空數(shù)據(jù)?清除后將無法恢復(fù)", 1 + vbokNo) = vbOK Then

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

End If

End Sub

返回光標所在行號

Sub 返回光標所在行號()

Range("A1") = Selection.Row

End Sub

VBA返回公式結(jié)果

Sub VBA返回公式結(jié)果()

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

Range("B1") = x

End Sub

按照當(dāng)前行A列的圖片名稱插入圖片到H列

Sub 按照當(dāng)前行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

當(dāng)前行下插入1行

Sub 當(dāng)前行下插入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

復(fù)制單元格所在行

Sub 復(fù)制單元格所在行()

    Selection.EntireRow.Copy

End Sub

復(fù)制單元格所在列

Sub 復(fù)制單元格所在列()

    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 '取得工作表總數(shù)

ReDim arr(1 To shtCnt) '預(yù)定義數(shù)組

i = 0

m = 1 '循環(huán)的次數(shù)

m1 = 0 '找到起點循環(huán)的次數(shù)

m2 = 0 '找到終點循環(huán)的次數(shù)

For Each Wks In ThisWorkbook.Sheets '在所有工作表中循環(huán)

    If Wks.Name = "A2" Then   '工作組中第一個工作表名稱

        i = i + 1

        arr(i) = Wks.Name '將工作表名稱存進數(shù)組

        m1 = m

    End If

    If Wks.Name Like "A7" Then    '工作組中最后一個個工作表名稱

        i = i + 1

        arr(i) = Wks.Name '將工作表名稱存進數(shù)組

        m2 = m

        Exit For

    End If

    If i > 0 And m > m1 Then

        i = i + 1

        arr(i) = Wks.Name '將工作表名稱存進數(shù)組

    End If

    m = m + 1

Next

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

    ReDim Preserve arr(1 To i) '重定義數(shù)組

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

End If

End Sub

在當(dāng)前工作組各表中分別執(zhí)行指定宏

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

Sub 在當(dāng)前工作組各表中分別執(zhí)行指定宏()

Dim SH As Worksheet

For Each SH In ActiveWindow.SelectedSheets

SH.Activate

臨時

Next

End Sub

    '臨時宏中原錄制代碼ActiveWorkbook.Names.Add Name:="臨時", RefersToR1C1:="=Sheet1!R1C1"      '插入名稱準備返回使用

    '臨時宏經(jīng)修改后的代碼ActiveWorkbook.names.Add Name:="臨時", RefersToR1C1:="=" + ActiveSheet.Name + "!R1C1"     '插入名稱準備返回使用

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

'其中指定宏代碼一定要避免執(zhí)行工作表的Select方法

Dim SelShts As Sheets

Dim Sht As Worksheet

Sub 在當(dāng)前工作組各表中分別執(zhí)行指定宏()

    Set SelShts = ActiveWindow.SelectedSheets

    For Each Sht In SelShts

       Call 臨時

    Next

End Sub

復(fù)制當(dāng)前工作簿的報表到臨時工作簿

Sub 復(fù)制當(dāng)前工作簿的報表到臨時工作簿()

'作者：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 "已經(jīng)有了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

需求說明：

'復(fù)制當(dāng)前工作簿的“報表”工作表到“臨時”工作簿為“001”表。

'如果“臨時”工作簿未打開，就創(chuàng)建新工作簿為“臨時”并在其中加入“001”表；

'如果“臨時”工作簿已經(jīng)打開，就直接加入“001”表。

'如果打開的“臨時”工作簿中已經(jīng)有“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的內(nèi)容寫到D15單元的批注中

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

Sub 將A1至C1的內(nèi)容寫到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