1、65 :刪除包含固定文本單元的行或列Sub刪除包含固定文本單元的行或列（）DoCells.Find(what:=哈哈).ActivateSelection.EntireRow.Delete 刪除行Selection.EntireColumn.Delete 刪除列Loop Until Cells.Find(what:=哈哈)Is NothingEnd Sub72 :在指定顏色區(qū)域選擇單元時添加/取消，（工作表代碼）Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim myrg As RangeIlliFor Each my

2、rg In TargetIf myrg.Interior.ColorIndex = 37 Then myrg = IIf(myrg NextEnd Sub73 :在指定區(qū)域選擇單元時添加/取消，(工作表代碼)Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng As RangeIf Target.Count = 15 ThenIf Not Application.Intersect(Target, Range(D6:D20) Is Nothing Then For Each Rng In SelectionWit

3、h RngIf .Value = Then.Value = VElse.Value =End IfEnd WithNextEnd IfEnd IfEnd Sub74 :雙擊指定單元，循環(huán)錄入文本（工作表代碼）Private Sub Worksheet_BeforeDoubleClick(ByVal T As Range, Cancel As Boolean)If T.Address $A$1 Then Exit SubCancel = TrueT = IIf(T = 好,中，IIf(T = 中, 差, 好) End Sub:雙擊指定單元，循環(huán)錄入文本(工作表代碼)Dim nums As Byt

4、ePrivate Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, CancelIf Target.Address = $A$1 Then nums = nums Mod 3 + 1Target = Mid( 上中下, nums, 1)Target.Offset(1, 0).SelectEnd IfEnd Sub:單元區(qū)域引用(工作表代碼)Private Sub Worksheet_Activate()Sheet1.Range(A1:B3).Value = Sheet2.Range(A1:B3).Value End Sub:在指定區(qū)域

5、選擇單元時數(shù)值加1 (工作表代碼)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Not Application.Intersect(a1:e10, Target) Is Nothing ThenTarget = Val(Target) + 1End IfEnd Sub259個常用宏-excelhome(3)2009-08-15 14:12:58:混合文本的編號Sub混合文本的編號()As Boolean)3, 100)Worksheets(1).Range(B2).Value = & (-(Mid(Workshee

6、ts(1).Range(B2),+ 1)End Sub:指定區(qū)域單元雙擊數(shù)據(jù)累加(工作表代碼)Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Not Application.Intersect(A1:Y100, Target) Is Nothing Thenoldvalue = Val(Target.Value)inputvalue = InputBox(請輸入數(shù)量，按ENTER1確認(rèn)！,” 數(shù)值累加器)Target.Value = oldvalue + inputvalue

7、End IfEnd Sub:選擇單元區(qū)域觸發(fā)事件(工作表代碼)Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Address = $A$1:$B$2 ThenMsgBox 你選擇了 $A$1:$B$2 單元End IfEnd Sub:當(dāng)修改指定單元容時自動執(zhí)行宏(工作表代碼)Private Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, B3:B4) Is Nothing Then重排窗口En

8、d IfEnd Sub:被指定單元容限制執(zhí)行宏Sub被指定單元限制執(zhí)行宏（）If Range（$A$1）= 關(guān)閉Then Exit Sub 窗口End Sub:雙擊單元隱藏該行（工作表代碼）Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Rows(Target.Row).Hidden = TrueEnd Sub: Wj鳧顯不行(工作表代碼)Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interi

9、or.ColorIndex = 2Rows(1:2).Interior.ColorIndex = 40保持 1 至 2 行的顏色推薦 39,22,40,Rows(Target.Row).Interior.ColorIndex= 35高亮推薦顏色35,20,24,34,37,40,15 End Sub:高亮顯示行和列(工作表代碼)Private Sub Worksheet_SelectionChange(ByVal Target As Range)Cells.Interior.ColorIndex = xlNoneRows(Target.Row).Interior.ColorIndex = 34

10、Columns(Target.Column).Interior.ColorIndex = 34End Sub:為指定工作表設(shè)置滾動圍(工作簿代碼)Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Sheetl.ScrollArea = A1:M30End Sub:在指定單元記錄打印和預(yù)覽次數(shù)(工作簿代碼)Private Sub Workbook_BeforePrint(Cancel As Boolean) Range(A1) = 1 + Range(A1)End Sub:自動數(shù)

11、字金額轉(zhuǎn)大寫(工作表代碼)Private Sub Worksheet_Change(ByVal M As Range)On Error Resume Nexty = Int(Round(100 * Abs(M) / 100)j = Round(100 * Abs(M) + 0.00001) - y * 100f = (j / 10 - Int(j / 10) * 10A = IIf(y 9.5, Application.Text(Int(j / 10), DBNum2) & 角, IIf(y 1,零”,”)c = IIf(f 1,整, Application.Text(Round(f, 0),

12、 DBNum2) & 分)M = IIf(Abs(M) 0.005, , IIf(M 0,負(fù)& A & b & c, A & b & c)End Sub:將所有工作表的 A1單元作為單擊按鈕(工作簿代碼)Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target AsRange)If Target.Address = $A$1 ThenCall 宏名End IfEnd Sub:鬧鐘一一到指定時間執(zhí)行宏(工作簿代碼)Private Sub Workbook_Open()Application.OnTime

13、(11:45:00),提示 1宏名字Application.OnTime (12:00:00),提示 2宏名字End Sub:改變Excel界面標(biāo)題的宏(工作簿代碼)Private Sub Workbook_Open()Application.Caption =春節(jié)快樂End Sub:在指定工作表的指定單元返回光標(biāo)當(dāng)前多選區(qū)地址(工作簿代碼)Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)Worksheets。，表 2).Range(A1) = Target.Address(

14、0, 0)End Sub: B列錄入數(shù)據(jù)時在A列返回記錄時間（工作表代碼）Public Sub Worksheet_Change(ByVal Target As Range)If Target.Column = 2 ThenTarget.Offset(, -1) = NowEnd IfEnd Sub:當(dāng)指定區(qū)域修改時在其右側(cè)的2個單元返回當(dāng)前日期和時間(工作表代碼)Public Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, A1:A1000) Is Nothing ThenIf T

15、arget.Column = 1 ThenTarget.Offset(, 1) = DateTarget.Offset(, 2) = TimeEnd IfEnd IfEnd SubPublic Sub Worksheet_Change(ByVal Target As Range)If Not Application.Intersect(Target, A1:A1000) Is Nothing ThenIf Target.Column = 1 ThenTarget.Offset(, 1) = Format(Now(), yyyy-mm-dd)Target.Offset(, 2) = Format

16、(Now(), h:mm:ss)End IfEnd IfEnd Sub:指定單元顯示光標(biāo)位置容(工作表代碼)Private Sub Worksheet_SelectionChange(ByVal T As Range) Sheets(1).Range(A1) = Selection End Sub:每編輯一個單元保存文件Private Sub Worksheet_Change(ByVal Target As Range)ThisWorkbook.SaveEnd Sub97 :指定允許編輯區(qū)域Sub指定允許編輯區(qū)域（）ActiveSheet.ScrollArea = B8:G15 End Sub

17、:解除允許編輯區(qū)域限制Sub解除允許編輯區(qū)域限制（）ActiveSheet.ScrollArea =End Sub:刪除指定行Sub刪除指定行（）Workbooks（臨時表）.Sheets（ 表 2）.Range（5:5）.DeleteEnd Sub:刪除A列為指定容的行Sub刪除A列為指定容的行（）Dim a, b As Integera = Sheet1.a65536.End（xlUp）.RowFor b = a To 2 Step -1If Cells（b, 1）.Value =刪除ThenRows（b）.DeleteEnd IfNextEnd Sub:刪除A列非數(shù)字單元行Sub刪除A列

18、非數(shù)字單元行（）i = a65536.End（xlUp）.RowRange（A1:A & i）.SpecialCells（xlCellTypeConstants, 2）.EntireRow.DeleteEnd Sub102 :有條件刪除當(dāng)前行Sub有條件刪除當(dāng)前行（）If A1 = 2 Or B1= 刪除ThenSelection.Delete Shift:=xlUpEnd IfEnd Sub103 :選擇下一行Sub選擇下一行()ActiveCell.Offset(1,0).Rows(1:1).EntireRow.SelectEnd Sub104 :選擇第5行開始所有數(shù)據(jù)行Sub選擇第5行開

19、始所有數(shù)據(jù)行 A()LookIn:=xlValues,Dim i%i= Cells.Find(*,SearchOrder:=xlByRows,SearchDirection:=xlPrevious).EntireRow.RowRows(5: & i).SelectEnd SubSub選擇第5行開始所有數(shù)據(jù)行 B()Rows(5: & Cells.Find(*”, , , , 1,2).Row).SelectEnd Sub105 :選擇光標(biāo)或選區(qū)所在行Sub選擇光標(biāo)或選區(qū)所在行()Selection.EntireRow.SelectEnd Sub106 :選擇光標(biāo)或選區(qū)所在列Sub選擇光標(biāo)或選區(qū)

20、所在列()Selection.EntireColumn.SelectEnd Sub107 :光標(biāo)定位到名稱指定位置名稱)Sub定位()Application.Goto Range(Evaluate(End Sub108 :選擇名稱定義的數(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 Sub109 :選擇到指定列的最后行Sub選擇到指定列的最后行()Range(C4:G & G65536.End(xlUp).Row).SelectEnd Sub110 :

21、將Sheet1的A列的非空值寫到 Sheet2的A列Sub將Sheet1的A列的非空值寫到 Sheet2的A列()Sheet1.Columns(A:A).SpecialCells(2, 23).SpecialCells(12).Copy Sheet2.A1 End Sub111:將名稱1的數(shù)據(jù)寫到名稱2Sub Macro2()Range(位置 2) = Range( 位置 1).ValueEnd Sub112 :單元反選Sub單元反選()Application.DisplayAlerts = FalseApplication.ScreenUpdating = FalseDim raddress

22、 As String, taddress As Stringraddress = Selection.Addresstaddress = ActiveSheet.UsedRange.AddressWith Sheets.Add.Range(taddress) = 0.Range(raddress) = =0raddress = .Range(taddress).SpecialCells(xlCellTypeConstants, 1).Address .Delete End WithActiveSheet.Range(raddress).Select Application.ScreenUpda

23、ting = True End Sub113 :調(diào)整選中對象中的文字Sub調(diào)整選中對象中的文字()文字居中：自動調(diào)整大小With Selection.HorizontalAlignment = xlCenter.VerticalAlignment = xlCenter.ReadingOrder = xlContext.Orientation = xlHorizontal.AutoSize = True.AddIndent = FalseEnd With End Sub114 :去除指定圍的對象Sub去除指定圍的對象()Dim p As ShapeSet My = Worksheets。，工作表

24、名)For Each p In My.ShapesIf Not Application.Intersect(p.TopLeftCell, Range(圍)Is Nothing Thenp.DeleteNext End Sub115 :更新透視表數(shù)據(jù)項(xiàng)Sub DeleteMissingItems2002All()防止數(shù)據(jù)透視表中顯示無用的數(shù)據(jù)項(xiàng)在Excel 2002 或更高版本中假如無用的數(shù)據(jù)項(xiàng)已經(jīng)存在，運(yùn)行這個宏可以更新Dim pt As PivotTableDim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsFor Each

25、pt In ws.PivotTablespt.PivotCache.MissingItemsLimit = xlMissingItemsNoneNext pt Next ws End Sub116:將所有工作表名稱寫到A列Sub將所有表名稱寫到 A列() k = 1For Each Sht In SheetsCells(k + 1,1) = Sht.Name 指定寫入的行和列k = k + 1Next End Sub117 :為當(dāng)前選定的多單元插入指定名稱Sub為當(dāng)前選定的多單元插入指定名稱()Selection.Name = 臨時ActiveWorkbook.Names.Add Name:=

26、臨時, RefersTo:=Selection 或者換用這行代碼也可以End Sub118 :刪除所有名稱Sub刪除所有名稱() On Error Resume Next Dim l As Integer l = ActiveWorkbook.Names.CountFor i = l To 1 Step -1ActiveWorkbook.Names(i).Delete Next End Sub119 :以指定區(qū)域?yàn)楸砟夸浹a(bǔ)充新表Sub以指定區(qū)域?yàn)楸砟夸浹a(bǔ)充新表()Dim dic As Object, sh As WorksheetDim arr, itemarr = Range(B1:BB1)

27、Set dic = CreateObject(scripting.dictionary)For Each sh In ThisWorkbook.Worksheetsdic.Add sh.Name,NextFor Each item In arrIf item And Not dic.exists(Trim(item) ThenWith ThisWorkbook.Worksheets.Add.Name = itemEnd WithEnd IfNextSet dic = NothingEnd Sub120 :按A列數(shù)據(jù)批量修改表名稱Sub按A列數(shù)據(jù)批量修改表名稱()Dim i%For i = 1

28、To Sheets.Count - 1Sheets(i).Name = Cells(i + 1, 1).TextNextEnd Sub121:按A列數(shù)據(jù)批量創(chuàng)建新表(控件按鈕代碼)Private Sub CommandButton1_Click()On Error Resume NextDim i%, j%For i = 1 To a65536.End(xlUp).RowFor j = 2 To Sheets.CountIf Cells(i, 1) = Sheets(j).Name ThenExit ForEnd IfNextSheets.Add(after:=Sheets(Sheets.Co

29、unt).Name = Cells(i, 1)NextEnd Sub122 :清除剪貼板Sub清除剪貼板()Application.CutCopyMode = FalseApplication.CommandBars(Task Pane).Visible = FalseEnd Sub123:批量清除軟回車Sub批量清除軟回車()也可直接使用 Alt+10或13替換Cells.Replace What:=Chr(10),Replacements,LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False

30、, ReplaceFormat:=FalseEnd Sub124 :判斷指定文件是否已經(jīng)打開Sub判斷指定文件是否已經(jīng)打開 () Dim x As IntegerFor x = 1 To Workbooks.CountIf Workbooks(x).Name =函數(shù).xls Then 文件名稱MsgBox 文件已打開 Exit SubEnd If Next MsgBox 文件未打開 End Sub125 :當(dāng)前文件另存到指定目錄Sub當(dāng)前激活文件另存到指定目錄（）信件 & ActiveWorkbook.NameEnd Sub126 :另存指定文件名Sub另存指定文件名（）別名.xls”End

31、Sub127 :以本工作表名稱另存文件到當(dāng)前目錄Sub以本工作表名稱另存文件到當(dāng)前目錄（）ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & & ActiveSheet.Name &.xls End Sub:將本工作表單獨(dú)另存文件到Excel當(dāng)前默認(rèn)目錄Sub將本工作表單獨(dú)另存文件到Excel當(dāng)前默認(rèn)目錄（）ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & .xls End Sub:以活動工作表名稱另存文件到Excel當(dāng)前默認(rèn)目錄Sub以活動工作表名稱另存文

32、件到Excel當(dāng)前默認(rèn)目錄（）ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & .xls, FileFormat:= _ xlNormal, Password:=, WriteResPassword:=, ReadOnlyRecommended:=False,CreateBackup:=False End Sub:另存所有工作表為工作簿Sub另存所有工作表為工作簿（） Dim sht As WorksheetApplication.ScreenUpdating = False ipath = ThisWorkbook.Path & For E

33、ach sht In Sheets sht.CopyActiveWorkbook.SaveAs ipath & sht.Name & .xls（工作表名稱為文件名）ActiveWorkbook.SaveAs ipath & sht.Name & Trim（sht.d15） & .xls（文件名稱& D15單元容）ActiveWorkbook.SaveAs ipath & Trim（sht.d15） & .xls（文件名稱為 D15單元容）ActiveWorkbook.CloseNextApplication.ScreenUpdating = True End Sub:以指定單元容為新文件名另存

34、文件Sub以指定單元容為新文件名另存文件()ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & & Sheet1.A1 End Sub:以當(dāng)前日期為新文件名另存文件Sub以當(dāng)前日期為新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & & Format(Now(), yyyymmdd) & .xls End SubSub以當(dāng)前日期為名稱另存文件 ()ActiveWorkbook.SaveAs Filename:=Date & .xls End Sub:以當(dāng)前日期和時間為新文件名另存文件Sub以當(dāng)前日期

35、和時間為新文件名另存文件()ThisWorkbook.SaveAs ThisWorkbook.Path & & Format(Now(), yyyy & 年& mm& 月& dd & 日& h & 時& mm & 分& ss & 秒)& .xls End Sub134 :另存本表為 TXT文件Sub另存本表為TXT文件()Dim s As StringDim FullName As String, rng As RangeApplication.ScreenUpdating = FalseFullName = (ActiveSheet.Name & .txt)以當(dāng)前表名為 TXT文件名Full

36、Name = Replace(ThisWorkbook.FullName, .xls,.txt)以當(dāng)前文件名為 TXT文件名FullName = Replace(ThisWorkbook.FullName, .xls, ActiveSheet.Name & .txt)以文件名砧名為TXT文件名Open FullName For Output As #1 以讀寫方式打開文件，每次寫容都會覆蓋原先的容 參考幫助，fullname為文件全名For Each rng In Range(a1).CurrentRegions = s & IIf(s = , , |) & rng.ValueIf rng.C

37、olumn = Range(a1).CurrentRegion.Columns.Count ThenPrint #1, s & |把數(shù)據(jù)寫到文本文件里End IfNextClose #1 關(guān)閉文件Application.ScreenUpdating = TrueMsgBox 數(shù)據(jù)已導(dǎo)入文本End Sub135 :引用指定位置單元容為部分文件名另存文件Sub引用指定位置單元容為部分文件名另存文件()信彳 & 解答& Range(sheet1!a1) & 郎 雀.xls” End Sub136 :將A列數(shù)據(jù)排序到 D列Sub將A列數(shù)據(jù)排序到D列()d:d = a:a.Valued:d.Sort K

38、ey1:=Range(D1), Order1:=xlAscending, Header:=xlYes End Sub137 :將指定圍的數(shù)據(jù)排列到D列Sub將指定圍的數(shù)據(jù)排列到D列()Dim arr1, arr2, i%, xarr1 = 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 Next xRange(D1).Resize(i, 1) = arr2End Sub光

39、標(biāo)移動Sub光標(biāo)移動()ActiveCell.Offset(1,2).Select 向下移動 1 行，向右移動 2 列End Sub138 :光標(biāo)所在行上移一行Sub光標(biāo)所在行上移一行()Dim i%i = Split(ActiveCell.Address, $)(2)If i 1 ThenRows(i).CutRows(i - 1).Insert Shift:=xlDownEnd IfEnd Sub139 :加數(shù)據(jù)有效限制Sub加數(shù)據(jù)有效限制()With Selection.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlV

40、alidAlertStop, Operator:= _xlBetween, Formula1:=bigsun010sina.IgnoreBlank = False.InCellDropdown = False.InputTitle =.ErrorTitle =.InputMessage =.ErrorMessage =要奮斗就會有犧牲，死人的事是經(jīng)常發(fā)生的。.IMEMode = xlIMEModeNoControl.ShowInput = True.ShowError = TrueEnd WithEnd Sub140 :取消數(shù)據(jù)有效限制Sub取消數(shù)據(jù)有效限制()With Selection.V

41、alidation.Delete.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween.IgnoreBlank = False.InCellDropdown = False.InputTitle =.ErrorTitle =.InputMessage =.ErrorMessage =.IMEMode = xlIMEModeNoControl.Showinput = True.ShowError = TrueEnd WithEnd Sub141:重排窗口Sub重排窗口（）Applic

42、ation.CommandBars（Web）.Visible = FalseApplication.CommandBars（我的工具）.Visible = FalseWindows.Arrange ArrangeStyle:=xlCascadeEnd Sub142 :按當(dāng)前單元文本選擇打開指定文件單元Sub選擇打開文件單元（）Dim aa = ActiveCell.ValueRange（a）.Worksheet.ActivateRange（a）.SelectEnd Sub143 :回車光標(biāo)向右Sub錄入光標(biāo)向右（）Application.MoveAfterReturnDirection = x

43、lToRightEnd Sub144 :回車光標(biāo)向下Sub錄入光標(biāo)向下（）Application.MoveAfterReturnDirection = xlDownEnd Sub145 :保護(hù)工作表時取消選定鎖定單元用于2000版Sub取消選定鎖定單元（）ActiveSheet.EnableSelection = xlUnlockedCellsEnd Sub146 :保存并退出 ExcelSub保存并退出 Excel()Application.SendKeys (ENTERENTER%fX) ActiveWorkbook.Save End Sub147 :隱藏/顯示指定列空值行Sub隱藏顯示E

44、列空值行()Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden= Not(Range(E1:E1000).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden) End Sub 148 :深度隱藏指定工作表Sub深度隱藏指定工作表()Sheets(用戶名密碼).Visible = xlVeryHidden End Sub149 :隱藏指定工作表Sub隱藏指定工作表()Sheets(用戶名密碼).Visible = false End Sub150 :隱藏當(dāng)前工作表Sub隱藏當(dāng)前

45、工作表()ActiveWindow.SelectedSheets.Visible = false End Sub151:返回當(dāng)前工作表名稱Sub返回當(dāng)前工作表名稱()wsName = ActiveSheet.NameMsgBox 當(dāng)前工作表為：& wsNameEnd Sub152 :獲取上一次所進(jìn)入工作簿的工作表名稱Sub獲取上一次所進(jìn)入工彳簿的工作表名稱()MsgBox Workbooks(2).ActiveSheet.NameEnd Sub153 :按光標(biāo)選定顏色隱藏本列其他顏色行Sub按顏色篩選()思路就是：其它背景色之行所有隱藏Dim UseRow, AC, i 首先選擇一個有顏色之單

46、元格，然后動行宏，其它顏色所在行隱藏UseRow=Cells.SpecialCells(xlCellTypeLastCell).RowSpecialCells(xlCellTypeLastCell)表示已用區(qū)域最后一個單元格If ActiveCell.Row UseRow ThenMsgBox 請?jiān)谝Y選的區(qū)域選擇一個有顏色之單元格！, vbExclamation, 錯誤ElseAC = ActiveCell.ColumnCells.EntireRow.Hidden = False 顯示所有行For i = 2 To UseRowIf Cells(i, AC).Interior.ColorIn

47、dex ActiveCell.Interior.ColorIndex ThenCells(i, AC).EntireRow.Hidden = True 假如2至已用行之單元格的有列之顏色不等于當(dāng) 前單元格顏色則隱藏整行End IfNextEnd IfEnd Sub154 :打開工作簿自動隱藏錄入表以外的其他表Private Sub Workbook_Open()Dim iFor i = 1 To Sheets.CountIf Sheets(i).Name 錄入ThenSheets(i).Visible = FalseEnd IfNextEnd Sub155 :除最左邊工作表外深度隱藏所有表Su

48、b除最左邊工作表外深度隱藏所有表()For i = 2 To ThisWorkbook.Sheets.CountSheets(i).Visible = xlSheetVeryHiddenNextEnd Sub156 :關(guān)閉文件時自動隱藏指定工作表(ThisWorkbook)Private Sub Workbook_BeforeClose(Cancel As Boolean)ActiveWorkbook.UnprotectSheets(Sheet2).Visible = FalseSheets(Sheet3).Visible = FalseActiveWorkbook.Protect Struc

49、ture:=True, Windows:=FalseEnd Sub157 :打開文件時提示指定工作表是保護(hù)狀態(tài)(ThisWorkbook)Private Sub Workbook_Open()If Worksheets(Sheet1).ProtectContents = True ThenMsgBox Sheet1 保護(hù)了 .End IfEnd Sub158 :插入10行Sub插入10彳t()Rows(ActiveCell.Row & : & ActiveCell.Row + 9).SelectSelection.Insert Shift:=xlDownEnd Sub159 :全選固定圍小于

50、0的單元Sub全選固定圍小于 0的單元()Dim rng As RangeDim yvhfFor Each rng In Range(d6: i18)If rng 0 Thenyvhf = yvhf & rng.Address & ,End IfNextRange(Left(yvhf, Len(yvhf) - 1).SelectEnd Sub160 :全選選定圍小于 0的單元Sub全選選定圍小于 0的單元()Dim rng As RangeDim yvhfFor Each rng In SelectionIf rng 0 Thenyvhf = yvhf & rng.Address & ,End

51、 IfNextRange(Left(yvhf, Len(yvhf) - 1).SelectEnd Sub161:固定區(qū)域單元分類變色Sub單元分類變色()Dim rng As RangeFor Each rng In Range(d6: i18)If rng 0 Thenrng.Interior.ColorIndex = 3 文本：假空和大于 0的單元變紅底色End IfNextFor Each rng In Range(d6: i18)If rng = 0 Thenrng.Interior.ColorIndex = 2 空值和等于0的單元變白底色End IfNextEnd Sub162 :

52、A列半角容變紅Sub A列半角容變紅()Dim rg As Range, i As LongApplication.ScreenUpdating = FalseFor Each rg In Cells.SpecialCells(xlCellTypeConstants, 3)For i = 1 To Len(rg)If Asc(Mid(rg, i, 1) 0 Then rg.Characters(i).Font.ColorIndex = 3NextNextApplication.ScreenUpdating = TrueEnd Sub163 :單元格錄入數(shù)據(jù)時運(yùn)行宏的代碼Private Sub

53、Worksheet_Change(ByVal Target As Range)重排窗口End Sub焦點(diǎn)到A列時運(yùn)行宏的代碼Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Column = 1 Then宏名End IfEnd Sub164 :根據(jù)B列最后數(shù)據(jù)快速合并 A列單元格的控件代碼Private Sub CommandButton1_Click()For i = 1 To b65536.End(xlUp).RowFor j = i + 1 To b65536.End(xlUp).RowIf Ran

54、ge(a & j) = ThenRange(a & i & :a & j).MergeElseExit ForEnd IfNext jNext iEnd Sub165 :在F1單元顯示光標(biāo)位置批注容的代碼Private Sub Worksheet_SelectionChange(ByVal Target As Range) a = Selection.Addressb = Range(a).NoteTextCells(1,6) = bEnd Sub166 :顯示光標(biāo)所在單元的批注的代碼Dim r As RangePrivate Sub Worksheet_SelectionChange(ByV

55、al Target As Range)On Error Resume Nextr.Comment.Visible = FalseSet r = Targetr.Comment.Visible = TrueEnd Sub167 :使單元容保持不變的工作表代碼Private Sub Worksheet_Change(ByVal Target As Range)B2=不可更改的數(shù)據(jù) End Sub168 :有條件執(zhí)行宏Sub高級篩選()If J1 = 2 Or K1=篩選ThenColumns(D:E).SelectSelection.ClearRange(D1).SelectColumns(A:B

56、).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _ G1:G2), CopyToRange:=Range(D1), Unique:=FalseEnd IfEnd Sub169 :有條件執(zhí)行不同的宏Sub有條件執(zhí)行不同的宏()If b1.Value = A ThenApplication.Run 宏 1ElseIf b1.Value = B ThenApplication.Run 宏 2 End IfEnd Sub259個常用宏-excelhome(4)2009-08-15 14:14:17170 :提示確定或取消執(zhí)行宏S

57、ub提示確定或取消執(zhí)行宏()If vbOK = MsgBox(確定要復(fù)制嗎？, vbOKCancel) ThenRange(A4:A14).Copy Range(b4:b14)Msgbox 復(fù)制結(jié)束End IfEnd Sub171:提不開始和結(jié)束Sub提示結(jié)束()Msgbox 運(yùn)行開始過程Msgbox 運(yùn)行結(jié)束 End Sub172 :拷貝指定表不相鄰多列數(shù)據(jù)到新位置Sub拷貝指定表不相鄰多列數(shù)據(jù)到新位置()Sheets(sheet1).Range(A:A,J:J).Copy Range(d1) End Sub173 :選擇2至4行Sub選才2 2至4行()Dim a As IntegerDi

58、m b As Integer a = 2 b = 4Rows(a & : & b).SelectEnd Sub174 :在當(dāng)前選區(qū)有條件替換數(shù)值為文本Sub在當(dāng)前選區(qū)有條件替換數(shù)值為文本（）For Each r In SelectionIf r.Value 18 And r.Value 29.5 Then r.Value = Y NextEnd Sub175:自動篩選所有顯示指定列Sub自動篩選所有顯示指定列（）Selection.AutoFilter Field:=1Selection.AutoFilter Field:=2Selection.AutoFilter Field:=3Selec

59、tion.AutoFilter Field:=4Selection.AutoFilter Field:=5Selection.AutoFilter Field:=6 End Sub176 :自動篩選第2列值為A的行Sub自動篩選第2列值為A的行0 a1.AutoFilter 2, aEnd Sub177 :取消自動篩選（）Sub取消自動篩選（）ActiveSheet.AutoFilterMode = False End Sub178 :所有顯示指定表的自動篩選Sub所有顯示指定表的自動篩選（）If Sheet1.FilterMode = True ThenSheet1.ShowAllDataE

60、nd IfEnd Sub179 :強(qiáng)行合并單元Sub強(qiáng)行合并單元()不出現(xiàn)對話框，按對話框默認(rèn)選擇Application.DisplayAlerts = False Range(a3:a4).MergeApplication.ScreenUpdating = True End Sub180 :設(shè)置單元區(qū)域格式Sub設(shè)置單元區(qū)域格式()a:a.NumberFormat = yyyy.mm.ddSheet2.B:B.NumberFormatLocal = yyyy-m-dSheet2.C:C.NumberFormatLocal = G/ 通用格式End Sub181:在所有工作表的A1單元返回順序