|
本文件部分文章來源于網(wǎng)絡(luò)
000. A列半角內(nèi)容變紅 Sub A列半角內(nèi)容變紅() ? Dim rg As Range, i As Long ? Application.ScreenUpdating = False ? For Each rg In Cells.SpecialCells(xlCellTypeConstants, 3) ??? For i = 1 To Len(rg) ????? If Asc(Mid(rg, i, 1))
001. A列等于A列減B列 Sub A列等于A列減B列() For i = 1 To 23 Cells(i, 1) = Cells(i, 1) - Cells(i, 2) Next End Sub
002. B列錄入數(shù)據(jù)時(shí)在A列返回記錄時(shí)間（工作表代碼） Public Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(, -1) = Now End If End Sub
003. Excel宏常用代碼 本大類暫沒有內(nèi)容，以下是關(guān)于本類的所有記錄集。
004. Sub 以當(dāng)前日期為名稱另存文件() ActiveWorkbook.SaveAs Filename:=Date & ".xls" End Sub
005. Sub 啟用保存() Application.CommandBars("File").Controls(4).Enabled = True Application.CommandBars("File").Controls(5).Enabled = True End Sub
006. Sub 執(zhí)行前需要驗(yàn)證密碼的宏() If InputBox("請(qǐng)輸入您的使用權(quán)限:", "系統(tǒng)提示") = 123 Then 重排窗口 ''要執(zhí)行的宏代碼或宏名稱 Else MsgBox "對(duì)不起,您沒有使用該宏的權(quán)限,按確定鍵后退出!" End If End Sub
007. Sub 選擇第5行開始所有數(shù)據(jù)行B() Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select End Sub
008. VBA返回公式結(jié)果 Sub VBA返回公式結(jié)果() x = Application.WorksheetFunction.Sum(Range("a2:a100")) Range("B1") = x End Sub
009. 不連續(xù)區(qū)域錄入對(duì)勾 Sub 批量錄入對(duì)勾() Selection.FormulaR1C1 = "√" End Sub
010. 不連續(xù)區(qū)域錄入當(dāng)前單元地址 Sub 區(qū)域錄入當(dāng)前單元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address Next End Sub
011. 不連續(xù)區(qū)域錄入當(dāng)前數(shù)字日期 Sub 區(qū)域錄入當(dāng)前數(shù)字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd") End Sub
012. 不連續(xù)區(qū)域錄入當(dāng)前文件名 Sub 批量錄入當(dāng)前文件名() Selection.FormulaR1C1 = ThisWorkbook.Name End Sub
013. 不連續(xù)區(qū)域錄入當(dāng)前日期 Sub 區(qū)域錄入當(dāng)前日期() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d") End Sub
014. 不連續(xù)區(qū)域錄入當(dāng)前日期和時(shí)間 Sub 區(qū)域錄入當(dāng)前日期和時(shí)間() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss") End Sub
015. 不連續(xù)區(qū)域插入當(dāng)前文件名和表名及地址 Sub 批量插入當(dāng)前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1C1 = "[" + ActiveWorkbook.Name + "]" + ActiveSheet.Name + "!" + mycell.Address Next End Sub
016. 不連續(xù)區(qū)域插入文本 Sub 批量插入文本() Dim s As Range For Each s In Selection s = "文本內(nèi)容" & s Next End Sub
017. 不連續(xù)區(qū)域添加文本 Sub 批量添加文本() Dim s As Range For Each s In Selection s = s & "文本內(nèi)容" Next End Sub
018. 為當(dāng)前選定的多單元插入指定名稱 Sub 為當(dāng)前選定的多單元插入指定名稱() Selection.Name = "臨時(shí)" ActiveWorkbook.Names.Add Name:="臨時(shí)", RefersTo:=Selection ''或者換用這行代碼也可以 End Sub
019. 為指定工作表加指定密碼保護(hù)表 Sub 為指定工作表加指定密碼保護(hù)表() Sheet10.Protect Password:="123" End Sub
020. 為指定工作表設(shè)置滾動(dòng)范圍（工作簿代碼） Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = "A1:M30" End Sub
021. 從指定位置向下同時(shí)錄入多單元指定內(nèi)容 Sub 從指定位置向下同時(shí)錄入多單元指定內(nèi)容() Dim arr arr = Array("1", "2", "13", "25", "46", "12", "0", "20") [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub
022. 以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
023. 以A1單元文本作表名插入工作表 Sub 以A1單元文本作表名插入工作表() Dim nm As String nm = [a1] Sheets.Add ActiveSheet.Name = nm End Sub
024. 以當(dāng)前日期為新文件名另存文件 Sub 以當(dāng)前日期為新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End Sub
025. 以當(dāng)前日期和時(shí)間為新文件名另存文件 Sub 以當(dāng)前日期和時(shí)間為新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "時(shí)" & "mm" & "分" & "ss" & "秒") & ".xls" End Sub
026. 以指定區(qū)域?yàn)楸砟夸浹a(bǔ)充新表 Sub 以指定區(qū)域?yàn)楸砟夸浹a(bǔ)充新表() Dim dic As Object, sh As Worksheet Dim arr, item arr = Range("B1:BB1") Set dic = CreateObject("scripting.dictionary") For Each sh In ThisWorkbook.Worksheets dic.Add sh.Name,
027. 以指定單元內(nèi)容為新文件名另存文件 Sub 以指定單元內(nèi)容為新文件名另存文件() ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1] End Sub
028. 以本工作表名稱另存文件到當(dāng)前目錄 Sub 以本工作表名稱另存文件到當(dāng)前目錄() ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls" End Sub
029. 以活動(dòng)工作表名稱另存文件到Excel當(dāng)前默認(rèn)目錄 Sub 以活動(dòng)工作表名稱另存文件到Excel當(dāng)前默認(rèn)目錄() ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=
030. 使單元內(nèi)容保持不變的工作表代碼 Private Sub Worksheet_Change(ByVal Target As Range) [B2] = "不可更改的數(shù)據(jù)" End Sub
031. 保存并退出Excel Sub 保存并退出Excel() Application.SendKeys ("{ENTER}{ENTER}%fx") ActiveWorkbook.Save End Sub
032. 保護(hù)工作表時(shí)取消選定鎖定單元 Sub 取消選定鎖定單元() ActiveSheet.EnableSelection = xlUnlockedCells ''用于2000版 End Sub
033. 光標(biāo)定位到名稱指定位置 Sub 定位() Application.Goto Range(Evaluate("名稱")) End Sub
034. 光標(biāo)定位到指定工作表A列最后數(shù)據(jù)行下一單元 Sub 光標(biāo)定位到指定工作表A列最后數(shù)據(jù)行下一單元() a = Sheets("數(shù)據(jù)庫").[a65536].End(xlUp).Row Sheets("數(shù)據(jù)庫").Select Range("A" & a + 1).Select End Sub
035. 光標(biāo)所在行上移一行 Sub 光標(biāo)所在行上移一行() Dim i% i = Split(ActiveCell.Address, "$")(2) If i > 1 Then Rows(i).Cut Rows(i - 1).Insert Shift:=xlDown End If End Sub
036. 光標(biāo)移動(dòng) Sub 光標(biāo)移動(dòng)() ActiveCell.Offset(1, 2).Select ''向下移動(dòng)1行，向右移動(dòng)2列 End Sub
037. 全選固定范圍內(nèi)小于0的單元 Sub 全選固定范圍內(nèi)小于0的單元() Dim rng As Range Dim yvhf For Each rng In Range("d6: i18") If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub
038. 全選選定范圍內(nèi)小于0的單元 Sub 全選選定范圍內(nèi)小于0的單元() Dim rng As Range Dim yvhf For Each rng In Selection If rng < 0 Then yvhf = yvhf & rng.Address & "," End If Next Range(Left(yvhf, Len(yvhf) - 1)).Select End Sub
039. 全部顯示指定表的自動(dòng)篩選 Sub 全部顯示指定表的自動(dòng)篩選() If Sheet1.FilterMode = True Then Sheet1.ShowAllData End If End Sub
040. 全部清除當(dāng)前選擇區(qū)域 Sub 全部清除當(dāng)前選擇區(qū)域() Selection.Clear '' Range("A1:B10").Clear ''全部清除指定區(qū)域 End Sub
041. 關(guān)閉文件時(shí)執(zhí)行指定宏(工作簿代碼) Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 ''要執(zhí)行的宏名稱 End Sub
042. 關(guān)閉文件時(shí)自動(dòng)隱藏指定工作表(ThisWorkbook) Private Sub Workbook_BeforeClose(Cancel As Boolean) ActiveWorkbook.Unprotect Sheets("Sheet2").Visible = False Sheets("Sheet3").Visible = False ActiveWorkbook.Protect Structure:=True, Windows:=Fal
043. 分離臨時(shí)表A列數(shù)據(jù)的文本和超鏈接并會(huì)同其他數(shù)據(jù)整理到數(shù)據(jù)庫表 Sub 分離A列數(shù)據(jù)的文本和超鏈接并會(huì)同其他數(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("臨時(shí)").Hyperlinks If hh.TextToDisplay =
044. 分離臨時(shí)表A列數(shù)據(jù)的文本和超鏈接并整理到數(shù)據(jù)庫表 Sub 分離A列中的超鏈接到指定表的B和C列() i = Worksheets("數(shù)據(jù)庫").Range("b60000").End(xlUp).Row For Each h In Worksheets("臨時(shí)").Hyperlinks Worksheets("數(shù)據(jù)庫").Cells(i + 1, 2) = h.TextToDisplay Worksheets("數(shù)據(jù)庫").Cells(
045. 刪除A列為指定內(nèi)容的行 Sub 刪除A列為指定內(nèi)容的行() Dim a, b As Integer a = Sheet1.[a65536].End(xlUp).Row For b = a To 2 Step -1 If Cells(b, 1).Value = "刪除" Then Rows(b).Delete End If Next End Sub
046. 刪除A列空行 Sub 刪除A列空行() Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub
047. 刪除A列非數(shù)字單元行 Sub 刪除A列非數(shù)字單元行() i = [a65536].End(xlUp).Row Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub
048. 刪除B列數(shù)據(jù)的超鏈接 Sub 刪除超鏈接() For Each Rng In Range("B3:B" & [B65536].End(xlUp).Row) Sheet1.Range(Rng.Address).Hyperlinks.Delete Next End Sub
049. 刪除全部名稱 Sub 刪除全部名稱() On Error Resume Next Dim l As Integer l = ActiveWorkbook.Names.Count For i = l To 1 Step -1 ActiveWorkbook.Names(i).Delete Next End Sub
050. 刪除全部未選定工作表 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.Selec
051. 刪除包含固定文本單元的行或列 Sub 刪除包含固定文本單元的行或列() Do Cells.Find(what:="哈哈").Activate Selection.EntireRow.Delete ''刪除行 '' Selection.EntireColumn.Delete ''刪除列 Loop Until Cells.Find(what:="哈哈") Is Nothing End Sub
052. 刪除指定文件 Sub 刪除指定文件() Kill "E:\信件\1.xls" End Sub
053. 刪除指定行 Sub 刪除指定行() Workbooks("臨時(shí)表").Sheets("表2").Range("5:5").Delete End Sub
054. 判斷指定文件是否已經(jīng)打開 Sub 判斷指定文件是否已經(jīng)打開() Dim x As Integer For x = 1 To Workbooks.Count If Workbooks(x).Name = "函數(shù).xls" Then ''文件名稱 MsgBox "文件已打開" Exit Sub End If Next MsgBox "文件未打開" End Sub
055. 加數(shù)據(jù)有效限制 Sub 加數(shù)據(jù)有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="bigsun010@sina.com" .IgnoreBlank = False .InCellDropd
056. 單元區(qū)域引用（工作表代碼） Private Sub Worksheet_Activate() Sheet1.Range("A1:B3").Value = Sheet2.Range("A1:B3").Value End Sub
057. 單元反選 Sub 單元反選() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim raddress As String, taddress As String raddress = Selection.Address taddress = ActiveSheet.UsedRange.Address
058. 單元格錄入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 "~"
059. 單元格錄入數(shù)據(jù)時(shí)運(yùn)行宏的代碼 Private Sub Worksheet_Change(ByVal Target As Range) 重排窗口 End Sub
060. 去除指定范圍內(nèi)的對(duì)象 Sub 去除指定范圍內(nèi)的對(duì)象() ??Dim p As Shape ??? Set My = Worksheets("工作表名") ??? For Each p In My.Shapes ??????? If Not Application.Intersect(p.TopLeftCell, Range("范圍")) Is Nothing Then p.Delete ??? Next
061. 雙擊單元執(zhí)行宏(工作表代碼) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Range("$A$1") = "關(guān)閉" Then Exit Sub Select Case Target.Address Case "$A$4" Call 宏1 Cancel = True Case "$B$4"
062. 雙擊單元隱藏該行（工作表代碼） Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows(Target.Row).Hidden = True End Sub
063. 雙擊指定區(qū)域單元執(zhí)行宏(工作表代碼) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Range("$A$1") = "關(guān)閉" Then Exit Sub If Not Application.Intersect(Target, Range("A4:A9", "C4:C9")) Is Nothing Then
064. 雙擊指定單元，循環(huán)錄入文本（工作表代碼） Dim nums As Byte Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address = "$A$1" Then nums = nums Mod 3 + 1 Target = Mid("上中下", nums, 1) Target.Offse
065. 反方向文本(自定義函數(shù)) Function zhyz(zhyz1 As Range) zhyz = StrReverse(zhyz1) End Function 將代碼復(fù)制到模塊后單元公式：=zhyz(單元格)
066. 取消指定行或列的隱藏 Sub 取消隱藏行() Rows("3:5").Select Selection.EntireRow.Hidden = False End Sub Sub 取消隱藏列() Columns("C:F").Select Selection.EntireColumn.Hidden = False End Sub
067. 取消數(shù)據(jù)有效限制 Sub 取消數(shù)據(jù)有效限制() With Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle =
068. 取消自動(dòng)篩選() Sub 取消自動(dòng)篩選() ActiveSheet.AutoFilterMode = False End Sub
069. 取消選定區(qū)域的公式只保留值(假空轉(zhuǎn)真空) Sub 取消選定區(qū)域的公式只保留值() ?''?? Sheets("數(shù)據(jù)歸并集中").Select ''指定工作表 ?''?? Columns("Q:R").Select ''指定范圍 Selection.Value = Selection.Value End Sub
070. 另存所有工作表為工作簿 Sub 另存所有工作表為工作簿() Dim sht As Worksheet Application.ScreenUpdating = False ipath = ThisWorkbook.Path & "\" For Each sht In Sheets sht.Copy ActiveWorkbook.SaveAs ipath & sht.Name & ".xls" ''(工作表名
071. 另存指定文件名 Sub 另存指定文件名() ActiveWorkbook.SaveAs ThisWorkbook.Path & "\別名.xls" End Sub
072. 另存本表為TXT文件 Sub 另存本表為TXT文件() Dim s As String Dim FullName As String, rng As Range Application.ScreenUpdating = False FullName = (ActiveSheet.Name & ".txt") ''以當(dāng)前表名為TXT文件名 '' FullName = Replace(ThisWorkboo
073. 右側(cè)單元自動(dòng)加5(工作表代碼) Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Target.Offset(0, 1) = Target + 5 Application.EnableEvents = True End Sub
074. 合并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:i
075. 合并各工作表內(nèi)容 Sub 合并各工作表內(nèi)容() sp = InputBox("各表內(nèi)容之間，間隔幾行？不輸則默認(rèn)為0") If sp = "" Then sp = 0 End If st = InputBox("各表從第幾行開始合并？不輸則默認(rèn)為2") If st = "" Then st = 2 End If Sheets(1).Select Sheets.Add If st
076. 合并指定目錄中所有文件中相同格式工作表的數(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
077. 回車光標(biāo)向下 Sub 錄入光標(biāo)向下() Application.MoveAfterReturnDirection = xlDown End Sub
078. 回車光標(biāo)向右 Sub 錄入光標(biāo)向右() Application.MoveAfterReturnDirection = xlToRight End Sub
079. 固定區(qū)域單元分類變色 Sub 單元分類變色() Dim rng As Range For Each rng In Range("d6: i18") If rng < 0 Then rng.Interior.ColorIndex = 4 ''小于0的單元變綠底色 End If Next For Each rng In Range("d6: i18") If rng > 0 Then rng.
080. 在A1返回當(dāng)前選中單元格數(shù)量 Sub 在A1返回當(dāng)前選中單元格數(shù)量() [A1] = Selection.Count End Sub
081. 在A列產(chǎn)生不重復(fù)隨機(jī)數(shù) Sub 在A列產(chǎn)生不重復(fù)隨機(jī)數(shù)() Randomize Timer Dim c(100) As Byte For i = 1 To 100 ''產(chǎn)生100個(gè)隨機(jī)數(shù) c(i) = i Next k = 100 Do While l < 100 r = Int(Rnd() * k) + 1 ''隨機(jī)數(shù)的范圍 aa = c(r) c(r) = c(k) c(k) = aa k =
082. 在A和B列返回當(dāng)前選區(qū)的名稱和公式 Sub 在A和B列返回當(dāng)前選區(qū)的名稱和公式() [a1].ListNames End Sub
083. 在F1單元顯示光標(biāo)位置批注內(nèi)容的代碼 Private Sub Worksheet_SelectionChange(ByVal Target As Range) a = Selection.Address b = Range(a).NoteText Cells(1, 6) = b End Sub
084. 在M和N列的14行以下選擇單元時(shí)顯示調(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
085. 在三個(gè)宏中依次循環(huán)執(zhí)行一個(gè)并相應(yīng)修改按鈕名稱（控件按鈕代碼） 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 S
086. 在兩個(gè)宏中依次循環(huán)執(zhí)行一個(gè)并相應(yīng)修改按鈕名稱（控件按鈕代碼） Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "保護(hù)工作表" Then Call 保護(hù)工作表 .Caption = "取消工作表保護(hù)" Exit Sub End If If .Caption = "取消工作表保護(hù)" Then Call 取消工作表保護(hù) .Caption = "保護(hù)工作表"
087. 在多個(gè)宏中依次循環(huán)執(zhí)行一個(gè)（控件按鈕代碼） 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
088. 在當(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 臨時(shí) N
089. 在當(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
090. 在所有工作表的A1單元返回順序號(hào) Sub 在所有工作表的A1單元返回順序號(hào)() For i = 1 To Sheets.Count Sheets(i).Cells(1, 1) = "''" & Application.WorksheetFunction.Text(0 + i, "000") Next End Sub
091. 在指定區(qū)域選擇單元時(shí)數(shù)值加1（工作表代碼） Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect([a1:e10], Target) Is Nothing Then Target = Val(Target) + 1 End If End Sub
092. 在指定單元記錄打印和預(yù)覽次數(shù)（工作簿代碼） Private Sub Workbook_BeforePrint(Cancel As Boolean) Range("A1") = 1 + Range("A1") End Sub
093. 在指定工作表的指定單元返回光標(biāo)當(dāng)前多選區(qū)地址（工作簿代碼） Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0) End Sub
094. 在有密碼的工作表執(zhí)行代碼 Sub 在有密碼的工作表執(zhí)行代碼() Sheets("1").Unprotect Password:=123 ''假定表名為“1”，密碼為“123” 打開工作表 Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True ''隱藏C列空值行 Sheets("1").Protect Password:=123
095. 在目錄表建立本工作簿中各表鏈接目錄 Sub 在目錄表建立本工作簿中各表鏈接目錄() Dim s%, Rng As Range On Error Resume Next Sheets("目錄").Activate If Err = 0 Then Sheets("目錄").UsedRange.Delete Else Sheets.Add ActiveSheet.Name = "目錄" End If For i =
096. 在第一個(gè)表前插入多工作表 Sub 在第一個(gè)表前插入多工作表() Sheets(1).Select For I = 1 To 50 Sheets.Add.Name = "新表" & I Next End Sub
097. 填公式 Sub 填公式() Range("C2:C12").Value = "=SUM(A2:B2)" End Sub
098. 處理導(dǎo)入的顯示為科學(xué)計(jì)數(shù)法樣式的身份證號(hào) Sub 處理導(dǎo)入的顯示為科學(xué)計(jì)數(shù)法樣式的身份證號(hào)() Selection.Value = Selection.Formula End Sub
099. 復(fù)制單元數(shù)值 Sub 復(fù)制數(shù)值() s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2") Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s End Sub
100. 復(fù)制單元格所在列 Sub 復(fù)制單元格所在列() Selection.EntireColumn.Copy End Sub
101. 復(fù)制單元格所在行 Sub 復(fù)制單元格所在行() Selection.EntireRow.Copy End Sub
102. 復(fù)制當(dāng)前工作簿的報(bào)表到臨時(shí)工作簿 Sub 復(fù)制當(dāng)前工作簿的報(bào)表到臨時(shí)工作簿() ''作者：yuanzhuping版主 Dim x As Integer Dim sht As Worksheet On Error Resume Next For x = 1 To Workbooks.Count If Workbooks(x).Name = "臨時(shí).xls" Then For Each sht In Workbook
103. 奇偶頁分別打印 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
104. 定義指定工作表標(biāo)簽顏色 Sub 定義指定工作表標(biāo)簽顏色() Sheets("Sheet1").Tab.ColorIndex = 46 End Sub
105. 定位數(shù)據(jù)及區(qū)域以上的空值 Sub 定位數(shù)據(jù)及區(qū)域以上的空值() Dim aa As Range For Each a In ActiveSheet.UsedRange If a Like〈0 Then If aa Is Nothing Then Set aa = a.Cells Else Set aa = Union(aa, a.Cells) End If End If Next aa.Select
106. 定位選定單元格式相同的全部單元格 Sub 定位選定單元格式相同的全部單元格() Dim FirstCell As Range, FoundCell As Range Dim AllCells As Range With Application.FindFormat .Clear .NumberFormatLocal = Selection.NumberFormatLocal .HorizontalAlignment =
107. 實(shí)現(xiàn)刪去特定的行
Sub test() For Each i In ThisWorkbook.Worksheets(1).range("E:E") If i.Value = "32766" Then Rows(i.Row).Delete End If Next i End Sub ''用的是第一張工作表，可以按需要改Worksheets(1)為指定的工作表。 這個(gè)宏指向的是當(dāng)前
108. 對(duì)指定工作表執(zhí)行取消隱藏》打印》隱藏工作表 Sub 打印隱藏工作表() Sheets("報(bào)表1").Visible = 1 Sheets("報(bào)表1").PrintOut Copies:=1, Collate:=True Sheets("報(bào)表1").Visible = 0 End Sub
109. 對(duì)第一張工作表的指定區(qū)域進(jìn)行排序 Sub 對(duì)第一張工作表的指定區(qū)域進(jìn)行排序() With Worksheets(1) .Range("a2:a100").Sort Key1:=.Range("a1") End With End Sub
110. 將A1單元錄入的數(shù)據(jù)累加到B1單元（工作表代碼） Private Sub Worksheet_Change(ByVal Target As Range) Dim t As Long If Target.Address = "$A$1" Then t = Sheet1.Range("$B$1").Value Sheet1.Range("$B$1").Value = t + Target.Value End If End Sub
111. 將A列數(shù)據(jù)排序到D列 Sub 將A列數(shù)據(jù)排序到D列() [d:d] = [a:a].Value [d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes End Sub
112. 將A列數(shù)據(jù)隨機(jī)排列到F列 Sub 將A列數(shù)據(jù)隨機(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
113. 將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 The
114. 將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:="點(diǎn)擊轉(zhuǎn)到:" &
115. 將Sheet1的A列的非空值寫到Sheet2的A列 Sub 將Sheet1的A列的非空值寫到Sheet2的A列() Sheet1.Columns("A:A").SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.[A1] End Sub
116. 將全部工作表名稱寫到A列 Sub 將全部表名稱寫到A列() k = 1 For Each Sht In Sheets Cells(k + 1, 1) = Sht.Name ''指定寫入的行和列 k = k + 1 Next End Sub
117. 將全部工作表的A1單元作為單擊按鈕（工作簿代碼） Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Target.Address = "$A$1" Then Call 宏名 End If End Sub
118. 將名稱1的數(shù)據(jù)寫到名稱2 Sub Macro2() Range("位置2") = Range("位置1").Value End Sub
119. 將所選區(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 + Act
120. 將指定范圍的數(shù)據(jù)排列到D列 Sub 將指定范圍的數(shù)據(jù)排列到D列() Dim arr1, arr2, i%, x arr1 = Range("A1:C3") ReDim arr2(1 To UBound(arr1, 1) * UBound(arr1, 2), 1 To 1) For Each x In Application.Transpose(arr1) i = i + 1 arr2(i, 1) = x Ne
121. 將本工作表單獨(dú)另存文件到Excel當(dāng)前默認(rèn)目錄 Sub 將本工作表單獨(dú)另存文件到Excel當(dāng)前默認(rèn)目錄() ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls" End Sub
122. 將第5行移到窗口的最上面 Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 5
123. 工作表中包含數(shù)據(jù)的最大行數(shù) Sub 包含數(shù)據(jù)的最大行數(shù)() n = Cells.Find("*", , , , 1, 2).Row MsgBox n End Sub
124. 工作表標(biāo)簽排序 Sub 工作表標(biāo)簽排序() Dim i As Long, j As Long, nums As Long, msg As Long msg = MsgBox("工作表按升序排列請(qǐng)選 ''是[Y]''. " & vbCrLf & vbCrLf & "工作表按降序排列請(qǐng)選 ''否[N]''", vbYesNoCancel, "工作表排序") If msg = vbCancel Then Exit
125. 延時(shí)15秒執(zhí)行重排窗口宏 Sub 延時(shí)15秒重排窗口() Application.OnTime Now + TimeValue("00:00:15"), "重排窗口" End Sub
126. 建立工作表文本目錄
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), "#" & Sheets(i).Name & "
127. 建立當(dāng)前工作表的副本為001表 Sub 建立當(dāng)前工作表的副本為001表() ActiveSheet.Copy Before:=Sheets(1) ActiveSheet.Name = "001" End Sub
128. 引用指定位置單元內(nèi)容為部分文件名另存文件 Sub 引用指定位置單元內(nèi)容為部分文件名另存文件() ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls" End Sub
129. 彈出打印對(duì)話框 Sub 彈出打印對(duì)話框() Application.Dialogs(xlDialogPrint).Show End Sub
130. 彈出提示A1單元內(nèi)容 Sub 彈出提示A1單元內(nèi)容() MsgBox "提示" & Range("A1").Value End Sub
131. 強(qiáng)行合并單元 Sub 強(qiáng)行合并單元() Application.DisplayAlerts = False ''不出現(xiàn)對(duì)話框，按對(duì)話框默認(rèn)選擇Range("a3:a4").Merge Application.ScreenUpdating = True End Sub
132. 當(dāng)修改指定單元內(nèi)容時(shí)自動(dòng)執(zhí)行宏（工作表代碼） Private Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then 重排窗口 End If End Sub
133. 當(dāng)前單元內(nèi)容返回到按鈕名稱（控件按鈕代碼） Private Sub CommandButton1_Click() CommandButton1.Caption = ActiveCell End Sub
134. 當(dāng)前單元加2 Sub 當(dāng)前單元加2() Selection = Selection + 2 ''Selection = Workbooks("臨時(shí)表").Sheets("表2").Range("A1") 調(diào)用指定地址內(nèi)容 End Sub
135. 當(dāng)前單元錄入計(jì)算機(jī)名 Sub 當(dāng)前單元錄入計(jì)算機(jī)名() Selection = Environ("COMPUTERNAME") ''Selection = Workbooks("臨時(shí)表").Sheets("表2").Range("A1") 調(diào)用指定地址內(nèi)容 End Sub
136. 當(dāng)前單元錄入計(jì)算機(jī)用戶名 Sub 當(dāng)前單元錄入計(jì)算機(jī)用戶名() Selection = Environ("Username") ''Selection = Workbooks("臨時(shí)表").Sheets("表2").Range("A1") 調(diào)用指定地址內(nèi)容 End Sub
137. 當(dāng)前單元返回按鈕名稱（控件按鈕代碼） Private Sub CommandButton1_Click() ActiveCell = CommandButton1.Caption End Sub
138. 當(dāng)前文件另存到指定目錄 Sub 當(dāng)前激活文件另存到指定目錄() ActiveWorkbook.SaveAs Filename:="E:\信件\" & ActiveWorkbook.Name End Sub
139. 當(dāng)前行下插入1行 Sub 當(dāng)前行下插入1行() Selection.Offset(1, 0).Insert End Sub
140. 當(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
141. 當(dāng)指定區(qū)域修改時(shí)在其右側(cè)的2個(gè)單元返回當(dāng)前日期和時(shí)間（工作表代碼） Public Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, [A1:A1000]) Is Nothing Then If Target.Column = 1 Then Target.Offset(, 1) = Date Target.Offset(, 2) = Time
142. 當(dāng)指定日期（每月10日）打開文件執(zhí)行宏 Sub auto_open() If Day(Date) = 10 Then 重排窗口 End If End Sub
143. 錄制宏時(shí)調(diào)用“停止錄制”工具欄 Sub 錄制宏時(shí)調(diào)用停止錄制工具欄() Application.CommandBars("Stop Recording").Visible = True End Sub
144. 循環(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("完成標(biāo)志") = "完成" Then Exit For
145. 手動(dòng)重算 Sub 手動(dòng)重算() With Application .Calculation = xlManual End With End Sub
146. 打開全部隱藏工作表 Sub 打開全部隱藏工作表() Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Visible = True Next i End Sub
147. 打開文件時(shí)執(zhí)行指定宏(工作簿代碼) Private Sub Workbook_Open() 重排窗口 ''要執(zhí)行的宏名稱 End Sub
148. 打開文件時(shí)提示指定工作表是保護(hù)狀態(tài)(ThisWorkbook) Private Sub Workbook_Open() If Worksheets("Sheet1").ProtectContents = True Then MsgBox " Sheet1保護(hù)了." End If End Sub
149. 執(zhí)行前需要驗(yàn)證密碼的宏(控件按鈕代碼) Private Sub CommandButton1_Click() If InputBox("請(qǐng)輸入密碼：") <> "123" Then ''密碼是123 MsgBox "密碼錯(cuò)誤,按確定退出!", 64, "提示" Exit Sub End If Cells(1, 1) = 10 End Sub
150. 批量處理單元格 Dim rng As Range Application.ScreenUpdating = False For Each rng In Selection If rng <> "" Then rng = rng * 7 Next
151. 批量插入地址批注 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:="本單元格：
152. 批量插入統(tǒng)一批注 Sub 批量插入統(tǒng)一批注() Dim r As Range, msg As String msg = InputBox("請(qǐng)輸入欲批量插入的批注", "提示", "隨便輸點(diǎn)什么吧") If Selection.Cells.Count > 0 Then For Each r In Selection r.AddComment r.Comment.Visible = False r.Co
153. 批量清除軟回車 Sub 批量清除軟回車() ''也可直接使用Alt+10或13替換 Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder:= _ xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub
154. 把a(bǔ)列不重復(fù)值取到e列 Sub 把a(bǔ)列不重復(fù)值取到e列() [A:A].AdvancedFilter 2, , [e1], 1 End Sub
155. 拷貝A1公式和格式到A2 Sub 拷貝A1公式到A2() Workbooks("臨時(shí)表").Sheets("表1").Range("A1").Copy Workbooks("臨時(shí)表").Sheets("表2").Range("A2").PasteSpecial End Sub
156. 拷貝指定表不相鄰多列數(shù)據(jù)到新位置 Sub 拷貝指定表不相鄰多列數(shù)據(jù)到新位置() Sheets("sheet1").Range("A:A,J:J").Copy Range("d1") End Sub
157. 指定允許編輯區(qū)域 Sub 指定允許編輯區(qū)域() ActiveSheet.ScrollArea = "B8:G15" End Sub
158. 指定區(qū)域單元雙擊數(shù)據(jù)累加（工作表代碼） Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Application.Intersect([A1:Y100], Target) Is Nothing Then oldvalue = Val(Target.Value) inputvalue = InputBox
159. 指定單元顯示光標(biāo)位置內(nèi)容（工作表代碼）
Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range("A1") = Selection End Sub
160. 指定單元的行高和列寬與A1單元相同 Sub 指定單元的行高和列寬與A1單元相同() Range("A1:F1").ColumnWidth = Range("A1").ColumnWidth ''指定列寬 Range("A2:A10").RowHeight = Range("A1").RowHeight ''指定行高 End Sub
161. 指定行高和列寬 Sub 指定行高和列寬() Range("A1:F1").ColumnWidth = 10 ''指定列寬 Range("A2:A10").RowHeight = 40 ''指定行高 End Sub Sub 指定行高和列寬() Columns("A:F").ColumnWidth = 10 ''指定列寬Rows("2:10").RowHeight = 40 ''指定行高
162. 指定選擇單元區(qū)域彈出消息 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$A$1:$C$3" Then MsgBox "你選擇對(duì)了" End If End Sub
163. 按aa工作表A列的內(nèi)容排列工作表標(biāo)簽順序 Sub 按aa工作表A列的內(nèi)容排列工作表標(biāo)簽順序() 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 =
164. 按A列數(shù)據(jù)批量修改表名稱 Sub 按A列數(shù)據(jù)批量修改表名稱() Dim i% For i = 1 To Sheets.Count - 1 Sheets(i).Name = Cells(i + 1, 1).Text Next End Sub
165. 按A列數(shù)據(jù)批量創(chuàng)建新表(控件按鈕代碼) Private Sub CommandButton1_Click() On Error Resume Next Dim i%, j% For i = 1 To [a65536].End(xlUp).Row For j = 2 To Sheets.Count If Cells(i, 1) = Sheets(j).Name Then Exit For End If Next She
166. 按光標(biāo)選定顏色隱藏本列其他顏色行 Sub 按顏色篩選() ''思路就是:其它背景色之行全部隱藏 Dim UseRow, AC, i ''首先選擇一個(gè)有顏色之單元格，然后動(dòng)行宏，其它顏色所在行隱藏 UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row ''SpecialCells(xlCellTypeLastCell)表示已用區(qū)域最后一個(gè)單元格 If ActiveCell.Row
167. 按固定文本定位 Sub 文本定位() Dim aa As Range For Each a In ActiveSheet.UsedRange If a Like "*合計(jì)*" Then If aa Is Nothing Then Set aa = a.Cells Else Set aa = Union(aa, a.Cells) End If End If Next aa.Select En
168. 按當(dāng)前單元文本定位 Sub 按當(dāng)前單元文本定位() ABC = Selection Dim aa As Range For Each a In ActiveSheet.UsedRange If a Like ABC Then If aa Is Nothing Then Set aa = a.Cells Else Set aa = Union(aa, a.Cells) End If End
169. 按當(dāng)前單元文本選擇打開指定文件單元 Sub 選擇打開文件單元() Dim a a = ActiveCell.Value Range(a).Worksheet.Activate Range(a).Select End Sub
170. 按照當(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").S
171. 提示并全部清除當(dāng)前選擇區(qū)域 Sub 提示并全部清除當(dāng)前選擇區(qū)域() If MsgBox("你確定要清除選擇的區(qū)域嗎?", vbYesNo, " 提示:") = vbYes Then Selection.Clear End Sub
172. 提示并清空單元區(qū)域 Sub 清空單元區(qū)域() If MsgBox("是否真的要清空數(shù)據(jù)?清除后將無法恢復(fù)", 1 + vbokNo) = vbOK Then Range("A1:B10,A15:B25").ClearContents End If End Sub
173. 提示開始和結(jié)束 ?Sub 提示結(jié)束() Msgbox "運(yùn)行開始" ?過程…… Msgbox "運(yùn)行結(jié)束" End Sub
174. 提示確定或取消執(zhí)行宏
Sub 提示確定或取消執(zhí)行宏() If vbOK = MsgBox("確定要復(fù)制嗎?", vbOKCancel) Then Range("A4:A14").Copy Range("b4:b14") Msgbox "復(fù)制結(jié)束" End If End Sub
175. 插入10行 Sub 插入10行() Rows(ActiveCell.Row & ":" & ActiveCell.Row + 9).Select Selection.Insert Shift:=xlDown End Sub
176. 插入數(shù)值條件格式 Sub 插入數(shù)值條件格式() Selection.FormatConditions.Delete Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:="70" Selection.FormatConditions(1).Interior.ColorIndex = 45 S
177. 插入透明批注 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).Sh
178. 撤消工作表保護(hù)并取消密碼 Sub 撤消工作表保護(hù)并取消密碼() ActiveSheet.Unprotect Password:=123456 End Sub
179. 改變Excel界面標(biāo)題的宏（工作簿代碼） Private Sub Workbook_Open() Application.Caption = "春節(jié)快樂" End Sub
180. 新建一個(gè)工作簿 Sub 新建一個(gè)工作簿() Workbooks.Add End Sub
181. 新建一個(gè)工作表 Sub 新建一個(gè)工作表() Sheets.Add End Sub
182. 顯示光標(biāo)所在單元的批注的代碼 Dim r As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next r.Comment.Visible = False Set r = Target r.Comment.Visible = True End Sub
183. 顯示指定工作表的打印預(yù)覽 Sub 顯示指定工作表的打印預(yù)覽() Worksheets("Sheet1").PrintPreview End Sub
184. 更新透視表數(shù)據(jù)項(xiàng) Sub DeleteMissingItems2002All() ''防止數(shù)據(jù)透視表中顯示無用的數(shù)據(jù)項(xiàng) ''在 Excel 2002 或更高版本中''如果無用的數(shù)據(jù)項(xiàng)已經(jīng)存在, ''運(yùn)行這個(gè)宏可以更新 Dim pt As PivotTable Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets For Each pt
185. 有條件刪除當(dāng)前行 Sub 有條件刪除當(dāng)前行() If [A1] = 2 Or [B1] = "刪除" Then Selection.Delete Shift:=xlUp End If End Sub
186. 有條件執(zhí)行不同的宏 Sub 有條件執(zhí)行不同的宏() If [b1].Value = "A" Then Application.Run "宏1" ElseIf [b1].Value = "B" Then Application.Run "宏2" End If End Sub
187. 有條件執(zhí)行宏 Sub 高級(jí)篩選() If [J1] = 2 Or [K1] = "篩選" Then Columns("D:E").Select Selection.Clear Range("D1").Select Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ "G1:G2"), CopyToR
188. 朗讀固定語句，請(qǐng)按ESC鍵終止 Sub 朗讀固定語句() On Error Resume Next Application.Speech.Speak "你好，節(jié)日快樂。", , , False If Err.Number <> 0 Then Application.Speech.Speak "", , , True End If End Sub
189. 朗讀朗讀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
190. 本示例為設(shè)置密碼窗口 (1) X = MsgBox("是否真的要結(jié)帳？", vbYesNo) If X = vbYes Then Close
191. 查另一文件的全部表名 Sub 查另一文件的全部表名() On Error Resume Next Dim i% Dim sh As Worksheet Application.ScreenUpdating = False Workbooks.Open Filename:=ThisWorkbook.Path & "\2.xls" Windows("1.xls").Activate ''當(dāng)前文件名稱 Sh
192. 查找A列文本循環(huán)插入分頁符 Sub 循環(huán)插入分頁符() '' Selection = Workbooks("臨時(shí)表").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代表循
193. 根據(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
194. 根據(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 = "合計(jì)" ElseIf Range("A1") = "C" Then Range("C1").FormulaR1C1
195. 根據(jù)B列最后數(shù)據(jù)快速合并A列單元格的控件代碼 Private Sub CommandButton1_Click() For i = 1 To [b65536].End(xlUp).Row For j = i + 1 To [b65536].End(xlUp).Row If Range("a" & j) = "" Then Range("a" & i & ":a" & j).Merge Else Exit For End If
196. 每編輯一個(gè)單元保存文件 Private Sub Worksheet_Change(ByVal Target As Range) ThisWorkbook.Save End Sub
197. 深度隱藏指定工作表 Sub 深度隱藏指定工作表() Sheets("用戶名密碼").Visible = xlVeryHidden End Sub
198. 混合文本的編號(hào) Sub 混合文本的編號(hào)() Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1) End Sub
199. 添加文本 Sub 添加文本() Selection = Selection + "×" ''不可在數(shù)字后添加文本 ''Selection = Workbooks("臨時(shí)表").Sheets("表2").Range("A1") 調(diào)用指定地址內(nèi)容 End Sub
200. 添加自定義序列 Sub 添加自定義序列() Application.AddCustomList ListArray:=Array("優(yōu)","良", "中", "差"，"劣") End Sub
201. 清除A列再插入序號(hào) Sub 清除A列再插入序號(hào)() ''Columns(1).ClearContents ''清除A列內(nèi)容 For i = 1 To 20 Range("a" & i) = i Next End Sub
202. 清除剪貼板 Sub 清除剪貼板() Application.CutCopyMode = False Application.CommandBars("Task Pane").Visible = False End Sub
203. 清除指定區(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
204. 焦點(diǎn)到A列時(shí)運(yùn)行宏的代碼 Private Sub Worksheet_SelectionChange(ByVal Target As Range) ??? If Target.Column = 1 Then 宏名??? End If End Sub
205. 用于光標(biāo)選定多區(qū)域跳轉(zhuǎn)指定單元(工作表代碼) Private Sub Worksheet_SelectionChange(ByVal T As Range) a = Array([b6:b7], [e6], [h6]) For i = 0 To 2 If Not Application.Intersect(T, a(i)) Is Nothing Then [a1].Select: Exit For End If Next En
206. 用單元格A1的內(nèi)容作為文件名另存當(dāng)前工作簿 Sub b() ActiveWorkbook.SaveCopyAs Range("A1") + ".xls" End Sub
207. 統(tǒng)計(jì)不同顏色的數(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)計(jì)紅色,輸入：=COLOR(B2:B8,3) ''統(tǒng)計(jì)藍(lán)色,輸入：=COLOR(B2:B8,5)
208. 統(tǒng)計(jì)指定范圍和內(nèi)容的單元數(shù)量 Sub 統(tǒng)計(jì)指定范圍和內(nèi)容的單元數(shù)量() x = Application.WorksheetFunction.CountIf(Range("A3:B100"), "總計(jì)") Range("B1") = x End Sub
209. 自動(dòng)打印多工作表第一頁 Sub 自動(dòng)打印多工作表第一頁() Dim sh As Integer Dim x Dim y Dim sy Dim syz x = InputBox("請(qǐng)輸入起始工作表名字:") sy = InputBox("請(qǐng)輸入結(jié)束工作表名字:") y = Sheets(x).Index syz = Sheets(sy).Index For sh = y To syz Sheets(s
210. 自動(dòng)數(shù)字金額轉(zhuǎn)大寫（工作表代碼） Function DX(M) y = Int(Round(100 * Abs(M)) / 100) j = Round(100 * Abs(M) + 0.00001) - y * 100 f = (j / 10 - Int(j / 10)) * 10 A = IIf(y < 1, "", Application.Text(y, "[DBNum2]") & "元") b = IIf(j > 9.5, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 1, "零", ""))) c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分") DX = IIf(Abs(M) < 0.005, "", IIf(M < 0, "負(fù)" & A & b & c, A & b & c)) End Function 211. 自動(dòng)篩選全部顯示指定列
Sub 自動(dòng)篩選全部顯示指定列() Selection.AutoFilter Field:=1 Selection.AutoFilter Field:=2 Selection.AutoFilter Field:=3 Selection.AutoFilter Field:=4 Selection.AutoFilter Field:=5 Selection.AutoFilter Fiel
212. 自動(dòng)篩選第2列值為A的行 Sub 自動(dòng)篩選第2列值為A的行() [a1].AutoFilter 2, "a" End Sub
213. 自動(dòng)重算 Sub 自動(dòng)重算() With Application .Calculation = xlAutomatic End With End Sub
214. 獲取上一次所進(jìn)入工作簿的工作表名稱 Sub 獲取上一次所進(jìn)入工作簿的工作表名稱() MsgBox Workbooks(2).ActiveSheet.Name End Sub
215. 被指定單元內(nèi)容限制執(zhí)行宏 Sub 被指定單元限制執(zhí)行宏() If Range("$A$1") = "關(guān)閉" Then Exit Sub 窗口 End Sub
216. 解除允許編輯區(qū)域限制 Sub 解除允許編輯區(qū)域限制() ActiveSheet.ScrollArea = "" End Sub
217. 解除全部工作表保護(hù) Sub 解除全部工作表保護(hù)() Dim n As Integer ??? For n = 1 To Sheets.Count ??????? Sheets(n).Unprotect ??? Next n End Sub
218. 設(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
219. 調(diào)整選中對(duì)象中的文字 Sub 調(diào)整選中對(duì)象中的文字() ''文字居中、自動(dòng)調(diào)整大小 With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext .Orientation = xlHorizontal .AutoSize = True .AddIndent =
220. 返回A列數(shù)據(jù)的最大行數(shù) Sub 返回A列數(shù)據(jù)的最大行數(shù)() n = Range("a65536").End(xlUp).Row Range("B1") = n End Sub
221. 返回A列最后一個(gè)非空單元行號(hào) Sub 返回A列最后非空單元行號(hào)() MsgBox Cells.Range("A65536").End(xlUp).Row End Sub
222. 返回A列非空單元數(shù)量 Sub 返回A列非空單元數(shù)量() y = Application.CountA(Columns(1)) MsgBox y End Sub
223. 返回光標(biāo)所在行號(hào) Sub 返回光標(biāo)所在行號(hào)() Range("A1") = Selection.Row End Sub
224. 返回光標(biāo)所在行數(shù) Sub 返回光標(biāo)所在行數(shù)() x = ActiveCell.Row Range("A1") = x End Sub
225. 返回光標(biāo)選擇區(qū)域的行數(shù)和列數(shù) Sub 返回光標(biāo)選擇區(qū)域的行數(shù)和列數(shù)() x = Selection.Rows.Count y = Selection.Columns.Count Range("A1") = x Range("A2") = y End Sub
226. 返回圓周率π Sub Macro1() Range("A1") = Application.Pi() End Sub
227. 返回當(dāng)前單元地址 Sub 返回當(dāng)前單元地址() d = ActiveCell.Address [A1] = d End Sub
228. 返回當(dāng)前工作簿中工作表數(shù)量 Sub 返回當(dāng)前工作簿中工作表數(shù)量() t = Application.Sheets.Count MsgBox t End Sub
229. 返回當(dāng)前工作表名稱 Sub 返回當(dāng)前工作表名稱() wsName = ActiveSheet.Name MsgBox "當(dāng)前工作表為：" & wsName End Sub
230. 返回總頁碼 Sub 返回總頁碼() Dim a Sheet1.Activate a = ExecuteExcel4Macro("Get.Document(50)") Range("A1") = a End Sub
231. 返回指定單元的行高和列寬 Sub 返回指定單元的行高和列寬() [c2] = Range("A1").ColumnWidth ''列寬 [b2] = Range("A1").RowHeight ''行高 End Sub Sub 返回指定單元的行高和列寬() Dim r%, c% r = [a1].RowHeight c = [a1].ColumnWidth [b2] = r ''行高 [c2]
232. 返回第1行最右邊非空單元的列號(hào) Sub 返回第1行最右邊非空單元的列號(hào)() X = [IV1].End(xlToLeft).Column MsgBox X End Sub
233. 返回第一個(gè)數(shù)值行號(hào) Sub 返回第一個(gè)數(shù)值行號(hào)() MsgBox [b:b].SpecialCells(2, 1).Row End Sub
234. 返回表中各非空單元區(qū)域地址(行搜索) Sub 返回表中各非空單元區(qū)域地址() MsgBox Cells.SpecialCells(2).Address End Sub
235. 返回表中第一個(gè)非空單元地址(行搜索) Sub 返回表中第一個(gè)非空單元地址() MsgBox Cells.Find("*").Address End Sub
236. 返回連續(xù)數(shù)值單元的數(shù)量 Sub 返回連續(xù)數(shù)值單元的數(shù)量() MsgBox [b:b].SpecialCells(2, 1).Rows.Count End Sub
237. 返回非空單元數(shù)量 Sub 返回非空單元數(shù)量() x = Application.CountA(Range("A1:Z65536")) MsgBox x End Sub
238. 進(jìn)入單元執(zhí)行宏(工作表代碼) Private Sub Worksheet_SelectionChange(ByVal Target As Range) ''以單元格進(jìn)入代替按鈕對(duì)象調(diào)用宏 If Range("$A$1") = "關(guān)閉" Then Exit Sub Select Case Target.Address Case "$A$5" ''單元地址(Target.Address),或命名單元名字(Target.Nam
239. 進(jìn)入指定區(qū)域單元執(zhí)行宏(工作表代碼) Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Range("$A$1") = "關(guān)閉" Then Exit Sub If Not Application.Intersect(Target, Range("A4:A9","C4:C9")) Is Nothing Then Call 打開隱藏表 End Sub
240. 連續(xù)區(qū)域錄入當(dāng)前單元地址 Sub 連續(xù)區(qū)域錄入當(dāng)前單元地址() Selection = "=ADDRESS(ROW(),COLUMN(),4,1)" Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub
241. 選擇2至4行 Sub 選擇2至4行() Dim a As Integer Dim b As Integer a = 2 b = 4 Rows(a & ":" & b).Select End Sub
242. 選擇下一行 Sub 選擇下一行() ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select End Sub
243. 選擇光標(biāo)或選區(qū)所在列 Sub 選擇光標(biāo)或選區(qū)所在列() Selection.EntireColumn.Select End Sub
244. 選擇光標(biāo)或選區(qū)所在行 Sub 選擇光標(biāo)或選區(qū)所在行() Selection.EntireRow.Select End Sub
245. 選擇到指定列的最后行 Sub 選擇到指定列的最后行() Range("C4:G" & [G65536].End(xlUp).Row).Select End Sub
246. 選擇單元區(qū)域觸發(fā)事件（工作表代碼） Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$A$1:$B$2" Then MsgBox "你選擇了$A$1:$B$2單元" End If End Sub
247. 選擇名稱定義的數(shù)據(jù)區(qū) Sub 選擇名稱定義的數(shù)據(jù)區(qū)() [數(shù)據(jù)區(qū)].Select ''插入名稱要使用INDIRECT函數(shù) ''Range("數(shù)據(jù)區(qū)").Select或者 ''Sheet1.Range("數(shù)據(jù)區(qū)").Select 或者 End Sub
248. 選擇多表為工作組 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 sh
249. 選擇第5行開始所有數(shù)據(jù)行 Sub 選擇第5行開始所有數(shù)據(jù)行A() Dim i% i = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).EntireRow.Row Rows("5:" & i).Select End Sub
250. 重排窗口 Sub 重排窗口() Application.CommandBars("Web").Visible = False Application.CommandBars("我的工具").Visible = False Windows.Arrange ArrangeStyle:=xlCascade End Sub
251. 重算指定表 Sub 重算指定表() Worksheets("傳送參數(shù)").Calculate Worksheets("目錄").Calculate End Sub
252. 鬧鐘——到指定時(shí)間執(zhí)行宏（工作簿代碼）
Private Sub Workbook_Open() Application.OnTime ("11:45:00"), "提示1" ''宏名字 Application.OnTime ("12:00:00"), "提示2" ''宏名字 End Sub
253. 除最左邊工作表外深度隱藏所有表 Sub 除最左邊工作表外深度隱藏所有表() For i = 2 To ThisWorkbook.Sheets.Count Sheets(i).Visible = xlSheetVeryHidden Next End Sub
254. 隱藏當(dāng)前工作表 Sub 隱藏當(dāng)前工作表() ActiveWindow.SelectedSheets.Visible = false End Sub
255. 隱藏指定工作表 Sub 隱藏指定工作表() Sheets("用戶名密碼").Visible = false End Sub
256. 隱藏指定工作表的指定列 Sub 隱藏指定工作表的指定列() Sheet1.Columns("B:B").EntireColumn.Hidden = True End Sub
257. 高亮顯示行和列（工作表代碼） Private Sub Worksheet_SelectionChange(ByVal Target As Range) Cells.Interior.ColorIndex = xlNone Rows(Target.Row).Interior.ColorIndex = 34 Columns(Target.Column).Interior.ColorIndex = 34 End Sub
258. 高亮顯示行（工作表代碼） Private Sub Worksheet_SelectionChange(ByVal Target As Range) Cells.Interior.ColorIndex = 2 Rows("1:2").Interior.ColorIndex = 40 ''保持1至2行的顏色推薦39,22,40, Rows(Target.Row).Interior.ColorIndex = 35
259. 高級(jí)篩選5列不重復(fù)數(shù)據(jù)至指定表 Sub 高級(jí)篩選5列不重復(fù)數(shù)據(jù)至Sheet2() Sheets("Sheet2").Range("A1:E65536") = "" ''清除Sheet2的A:D列Range("A1:E65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range( _ "A1"), Unique:=True Sheet2.Co 260. 大寫金額 Sub 大寫金額() |
|
|
