精华内容
下载资源
问答
  • 1、概述 为了加速代码编写,我们可以首先通过录制Word的方式来查看完成相应功能所需要的代码,然后转换为JavaScript代码。本文以插入表格为例,描述将转换为Javascript代码的过程及注意问题。[本文大部分内容...

    1、概述


    • 为了加速代码编写,我们可以首先通过录制Word宏的方式来查看完成相应功能所需要的代码,然后转换为JavaScript代码。本文以插入表格为例,描述将宏转换为Javascript代码的过程及注意问题。[本文大部分内容同时适应于EXCEL]


    2、为什么不直接在文档中使用宏

    • 1)在Word 2003中,由于安全性问题,默认情况下宏是被禁用的,不能被执行。
      2)有宏的文档在打开的时候会有安全性提示,导致用户感觉不友好。


    3、开始录制插入表格宏


    • 1)打开word。选择工具->宏->录制新宏:
    •  
    •  

      2)在随后出现的窗口中,“将宏保存在:”下拉框中,选择文档1(文档) 3)从常用工具栏中,点击插入表格按钮,并选择一个3行3列的表格,如下图: 4)在宏录制工具栏上,点击停止录制按钮,如下图所示: 5)此时,文档中出现了一个3行3列的表格。如下图所示:

    4、查看宏代码

    1)选择工具->宏->Visual Basic 编辑器。如下图所示。

    2)在出现的Visual Basic窗口中,从左边展开Project(文档1)中的模块,并双击NewMacros。如下图:

    3)右边窗口中的代码如下:

    •  
      •  
        •  
          • .Style = "网格型"
        • If .Style <> "网格型" Then End If
          .ApplyStyleHeadingRows = True
          .ApplyStyleLastRow = True
          .ApplyStyleFirstColumn = True
          .ApplyStyleLastColumn = True
      • ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:= _
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
        With Selection.Tables(1) End With
    • Sub Macro1()
      '
      ' Macro1 Macro
      ' 宏在 2007-02-02 由 用户19 录制
      ' End Sub

    5、VBA代码分析

    •  
      • ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:= _
        3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
        wdAutoFitFixed
      •  
        •  
          • .Style = "网格型"
        • If .Style <> "网格型" Then End If
          .ApplyStyleHeadingRows = True
          .ApplyStyleLastRow = True
          .ApplyStyleFirstColumn = True
          .ApplyStyleLastColumn = True
      • With Selection.Tables(1) End With

    • 以下是vba代码的分析。先看第一条语句: 以上语句调用了ActiveDocument的Tables集合对象的Add方法。添加一个Table对象到文档中。 以上语句设定当前插入点所在Table(也就是刚刚加入的Table对象 )的Tyle属性,以及ApplyStyleHeadingRows等属性。


    6、VBA代码转换为JavaScript代码应该注意的问题

      •  
        •  
          • ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:= _
            3, DefaultTableBehavior:= wdWord9TableBehavior , AutoFitBehavior:= _
            wdAutoFitFixed
          •  
            • MsgBox "wdWord9TableBehavior=" & wdWord9TableBehavior
          • Sub showConst() End Sub

        • 要得到VBA常量的数字值,可以在Visual Basic编辑器中,随便输入一个Sub过程,加入MessageBox 常量即可。比如,要显示 wdWord9TableBehavior 的常量值,代码如下图所示: 将光标定位到Msgbox语句所在行,点击工具栏上的运行按钮。如下图所示: 即可得到结果:
        •  
          • var mydoc = ntkoobj.ActiveDocument; //得到Document对象
            var app = mydoc.Application; //得到Application对象
            var sel = app.Selection; //得到Selection对象
      • 将VBA代码转换为JavaScript代码过程中,有几个问题需要注意:

        1)VBA中的常量应该使用数字代替。比如上面以下VBA语句中的wdWord9TableBehavior以及wdAutoFitFixed


        2)在VBA代码中,可以直接访问Application对象,ActiveDocument对象,以及Selection对象。但是在使用JavaScript对NTKO OFFICE文档控件中的Word对象编程时,首先是通过控件对象.ActiveDocument得到word的Document对象,然后通过Document对象的Application属性访问Application对象。然后再通过Application对象得到Selection对象。比如: 3)VBA函数或者过程调用支持命名参数。但是JavaScript调用不支持命名参数。因此,应该在Word编程帮助中找到相应方法的描述,按照从左到右的顺序写入参数。常量采用数字代替。中间不能有遗漏的参数。但是最后面的可选参数是可以省略的。
        4)注意VBA中的Bool类型的常量True和False,应该替换为Js中的true和false.
        5)注意其它Js和VBA的语法差别。比如,if语句等。以及每行js语句之后需要分号。

    7、转换为JavaScript代码

    照上述原则,以下VBA语句:

    8、测试JavaScript代码

      •  
        •  
          •  
            • style = "网格型";
          • if(style != "网格型")
            { }
            ApplyStyleHeadingRows = true;
            ApplyStyleLastRow = true;
            ApplyStyleFirstColumn = true;
            ApplyStyleLastColumn = true;
        • var mydoc = ntkoobj.ActiveDocument; //得到Document对象
          var app = mydoc.Application; //得到Application对象
          var sel = app.Selection; //得到Selection对象
          var tables = mydoc.Tables;
          var newTable = tables.Add(sel.Range,3,3,1,0);
          with(newTable)
          { }
      • 将第7节最后得到的js代码封装为一个function,并在包含NTKO OFFICE文档控件的网页中加入一个按钮调用:
        function testAddTable()
        { }
        ........................................
        <button οnclick="testAddTable()">测试添加表格</button>

    •  
      •  
        • .Style = "网格型"
      • If .Style <> "网格型" Then End If
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = True
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = True
    • ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=3, NumColumns:= _
      3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
      wdAutoFitFixed
      With Selection.Tables(1)
      End With

    可以遵循以下步骤被转换为如下JavaScript代码:
    首先查阅Tables集合的Add方法描述,在Word编程参考中对Tables对象的Add方法的描述如下:



    而通过第6节,第1)步所描述的方法,可以得到wdWord9TableBehavior=1,wdAutoFitFixed=0
    有了这些信息,就可以得到如下Js代码:

    •  
      •  
        • style = "网格型";
      • if(style != "网格型")
        {
        }
        ApplyStyleHeadingRows = true;
        ApplyStyleLastRow = true;
        ApplyStyleFirstColumn = true;
        ApplyStyleLastColumn = true;
    • var mydoc = ntkoobj.ActiveDocument; //得到Document对象
      var app = mydoc.Application; //得到Application对象
      var sel = app.Selection; //得到Selection对象
      var tables = mydoc.Tables;
      var newTable = tables.Add(sel.Range,3,3,1,0);
      with(newTable)
      {
      }
    展开全文
  • EXCEL宏代码大全

    万次阅读 2015-11-17 17:24:29
     If InputBox("请输入您的使用权限:", "系统提示") = 123 Then 重排窗口 '要执行的宏代码名称 Else MsgBox "对不起,您没有使用该的权限,按确定键后退出!" End If End Sub   007. Sub 选择第5行...

    本文件部分文章来源于网络,文章版权归原作者所有,如果本站转载的文章侵犯了您的权益请及时联系我们,我们将尽快妥善处理。本站除部分特别声明禁止转载的专稿外,其他文章可以自由转载,但请务必注明原出处和作者。

     

    000. A列半角内容变红

         Sub A列半角内容变红() ? 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列录入数据时在A列返回记录时间(工作表代码)

         Public Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Then Target.Offset(, -1) = Now End If End Sub

     

    003. Excel宏常用代码

         本大类暂没有内容,以下是关于本类的所有记录集。

     

    004. Sub 以当前日期为名称另存文件()

         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 执行前需要验证密码的宏()

         If InputBox("请输入您的使用权限:", "系统提示") = 123 Then 重排窗口 '要执行的宏代码或宏名称 Else MsgBox "对不起,您没有使用该宏的权限,按确定键后退出!" End If End Sub

     

    007. Sub 选择第5行开始所有数据行B()

         Rows("5:" & Cells.Find("*", , , , 1, 2).Row).Select End Sub

     

    008. VBA返回公式结果

         Sub VBA返回公式结果() x = Application.WorksheetFunction.Sum(Range("a2:a100")) Range("B1") = x End Sub

     

    009. 不连续区域录入对勾

         Sub 批量录入对勾() Selection.FormulaR1C1 = "√" End Sub

     

    010. 不连续区域录入当前单元地址

         Sub 区域录入当前单元地址() For Each mycell In Selection mycell.FormulaR1C1 = mycell.Address Next End Sub

     

    011. 不连续区域录入当前数字日期

         Sub 区域录入当前数字日期() Selection.FormulaR1C1 = Format(Now(), "yyyymmdd") End Sub

     

    012. 不连续区域录入当前文件名

         Sub 批量录入当前文件名() Selection.FormulaR1C1 = ThisWorkbook.Name End Sub

     

     013. 不连续区域录入当前日期

         Sub 区域录入当前日期() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d") End Sub

     

    014. 不连续区域录入当前日期和时间

         Sub 区域录入当前日期和时间() Selection.FormulaR1C1 = Format(Now(), "yyyy-m-d h:mm:ss") End Sub

     

    015. 不连续区域插入当前文件名和表名及地址

         Sub 批量插入当前文件名和表名及地址() For Each mycell In Selection mycell.FormulaR1C1 = "[" + ActiveWorkbook.Name + "]" + ActiveSheet.Name + "!" + mycell.Address Next End Sub

     

    016. 不连续区域插入文本

         Sub 批量插入文本() Dim s As Range For Each s In Selection s = "文本内容" & s Next End Sub

     

    017. 不连续区域添加文本

         Sub 批量添加文本() Dim s As Range For Each s In Selection s = s & "文本内容" Next End Sub

     

    018. 为当前选定的多单元插入指定名称

         Sub 为当前选定的多单元插入指定名称() Selection.Name = "临时" ActiveWorkbook.Names.Add Name:="临时", RefersTo:=Selection '或者换用这行代码也可以 End Sub

     

    019. 为指定工作表加指定密码保护表

         Sub 为指定工作表加指定密码保护表() Sheet10.Protect Password:="123" End Sub

     

    020. 为指定工作表设置滚动范围(工作簿代码)

         Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Sheet1.ScrollArea = "A1:M30" End Sub

     

    021. 从指定位置向下同时录入多单元指定内容

         Sub 从指定位置向下同时录入多单元指定内容() Dim arr arr = Array("1", "2", "13", "25", "46", "12", "0", "20") [B2].Resize(8, 1) = Application.WorksheetFunction.Transpose(arr) End Sub

     

    022. 以A1单元内容批量插入批注

         Sub 以A1单元内容批量插入批注() 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. 以当前日期为新文件名另存文件

         Sub 以当前日期为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyymmdd") & ".xls" End Sub

     

    025. 以当前日期和时间为新文件名另存文件

         Sub 以当前日期和时间为新文件名另存文件() ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Now(), "yyyy" & "年" & "mm" & "月" & "dd" & "日" & "h" & "时" & "mm" & "分" & "ss" & "秒") & ".xls" End Sub

     

    026. 以指定区域为表目录补充新表

         Sub 以指定区域为表目录补充新表() 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. 以指定单元内容为新文件名另存文件

         Sub 以指定单元内容为新文件名另存文件() ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheet1.[A1] End Sub

     

    028. 以本工作表名称另存文件到当前目录

         Sub 以本工作表名称另存文件到当前目录() ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xls" End Sub

     

    029. 以活动工作表名称另存文件到Excel当前默认目录

         Sub 以活动工作表名称另存文件到Excel当前默认目录() ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=

     

    030. 使单元内容保持不变的工作表代码

         Private Sub Worksheet_Change(ByVal Target As Range) [B2] = "不可更改的数据" End Sub

     

    031. 保存并退出Excel

         Sub 保存并退出Excel() Application.SendKeys ("{ENTER}{ENTER}%fx") ActiveWorkbook.Save End Sub

     

    032. 保护工作表时取消选定锁定单元

         Sub 取消选定锁定单元() ActiveSheet.EnableSelection = xlUnlockedCells '用于2000版 End Sub

     

    033. 光标定位到名称指定位置

         Sub 定位() Application.Goto Range(Evaluate("名称")) End Sub

     

    034. 光标定位到指定工作表A列最后数据行下一单元

         Sub 光标定位到指定工作表A列最后数据行下一单元() a = Sheets("数据库").[a65536].End(xlUp).Row Sheets("数据库").Select Range("A" & a + 1).Select End Sub

     

    035. 光标所在行上移一行

         Sub 光标所在行上移一行() 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. 光标移动

         Sub 光标移动() ActiveCell.Offset(1, 2).Select '向下移动1行,向右移动2列 End Sub

     

    037. 全选固定范围内小于0的单元

         Sub 全选固定范围内小于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. 全选选定范围内小于0的单元

         Sub 全选选定范围内小于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. 全部显示指定表的自动筛选

         Sub 全部显示指定表的自动筛选() If Sheet1.FilterMode = True Then Sheet1.ShowAllData End If End Sub

     

    040. 全部清除当前选择区域

         Sub 全部清除当前选择区域() Selection.Clear ' Range("A1:B10").Clear '全部清除指定区域 End Sub

     

    041. 关闭文件时执行指定宏(工作簿代码)

         Private Sub Workbook_BeforeClose(Cancel As Boolean) 重排窗口 '要执行的宏名称 End Sub

     

    042. 关闭文件时自动隐藏指定工作表(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. 分离临时表A列数据的文本和超链接并会同其他数据整理到数据库表

         Sub 分离A列数据的文本和超链接并会同其他数据整理到指定表() ier = Worksheets("数据库").Range("b60000").End(xlUp).Row For ee = 5 To Range("a60000").End(xlUp).Row For Each hh In Worksheets("临时").Hyperlinks If hh.TextToDisplay =

     

    044. 分离临时表A列数据的文本和超链接并整理到数据库表

         Sub 分离A列中的超链接到指定表的B和C列() i = Worksheets("数据库").Range("b60000").End(xlUp).Row For Each h In Worksheets("临时").Hyperlinks Worksheets("数据库").Cells(i + 1, 2) = h.TextToDisplay Worksheets("数据库").Cells(

     

    045. 删除A列为指定内容的行

         Sub 删除A列为指定内容的行() 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列非数字单元行

         Sub 删除A列非数字单元行() i = [a65536].End(xlUp).Row Range("A1:A" & i).SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete End Sub

     

    048. 删除B列数据的超链接

         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("临时表").Sheets("表2").Range("5:5").Delete End Sub

     

    054. 判断指定文件是否已经打开

         Sub 判断指定文件是否已经打开() Dim x As Integer For x = 1 To Workbooks.Count If Workbooks(x).Name = "函数.xls" Then '文件名称 MsgBox "文件已打开" Exit Sub End If Next MsgBox "文件未打开" End Sub

     

    055. 加数据有效限制

         Sub 加数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="bigsun010@sina.com" .IgnoreBlank = False .InCellDropd

     

    056. 单元区域引用(工作表代码)

         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位字符就跳转(工作表代码)

         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. 单元格录入数据时运行宏的代码

         Private Sub Worksheet_Change(ByVal Target As Range) 重排窗口 End Sub

     

    060. 去除指定范围内的对象

         Sub 去除指定范围内的对象() ??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. 双击单元执行宏(工作表代码)

         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"

     

    062. 双击单元隐藏该行(工作表代码)

         Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Rows(Target.Row).Hidden = True End Sub

     

    063. 双击指定区域单元执行宏(工作表代码)

         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

     

    064. 双击指定单元,循环录入文本(工作表代码)

         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. 反方向文本(自定义函数)

         Function zhyz(zhyz1 As Range) zhyz = StrReverse(zhyz1) End Function 将代码复制到模块后单元公式:=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. 取消数据有效限制

         Sub 取消数据有效限制() With Selection.Validation .Delete .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween .IgnoreBlank = False .InCellDropdown = False .InputTitle =

     

    068. 取消自动筛选()

         Sub 取消自动筛选() ActiveSheet.AutoFilterMode = False End Sub

     

    069. 取消选定区域的公式只保留值(假空转真空)

         Sub 取消选定区域的公式只保留值() ?'?? Sheets("数据归并集中").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") '以当前表名为TXT文件名 ' FullName = Replace(ThisWorkboo

     

    073. 右侧单元自动加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的内容写到D15单元的批注中

         ‘http://club.excelhome.net/dispbbs.asp?boardid=2&id=251887 northwolves版主 Sub 将A1至C1的内容写到D15单元的批注中() [iv1:iv12] = "=rc1 & "" ""& rc2 &"" ""& rc3" [d15].AddComment Join(Application.Transpose([iv1:i

     

    075. 合并各工作表内容

         Sub 合并各工作表内容() sp = InputBox("各表内容之间,间隔几行?不输则默认为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

     

    076. 合并指定目录中所有文件中相同格式工作表的数据

         Sub 合并数据() '合并指定目录中所有文件中相同格式工作表的数据 '见http://club.excelhome.net/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. 回车光标向下

         Sub 录入光标向下() Application.MoveAfterReturnDirection = xlDown End Sub

     

    078. 回车光标向右

         Sub 录入光标向右() Application.MoveAfterReturnDirection = xlToRight End Sub

     

    079. 固定区域单元分类变色

         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返回当前选中单元格数量

         Sub 在A1返回当前选中单元格数量() [A1] = Selection.Count End Sub

     

    081. 在A列产生不重复随机数

         Sub 在A列产生不重复随机数() Randomize Timer Dim c(100) As Byte For i = 1 To 100 '产生100个随机数 c(i) = i Next k = 100 Do While l < 100 r = Int(Rnd() * k) + 1 '随机数的范围 aa = c(r) c(r) = c(k) c(k) = aa k =

     

    082. 在A和B列返回当前选区的名称和公式

         Sub 在A和B列返回当前选区的名称和公式() [a1].ListNames End Sub

     

     083. 在F1单元显示光标位置批注内容的代码

         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行以下选择单元时显示调用日历控件(工作表代码)

         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. 在三个宏中依次循环执行一个并相应修改按钮名称(控件按钮代码)

         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. 在两个宏中依次循环执行一个并相应修改按钮名称(控件按钮代码)

         Private Sub CommandButton1_Click() With CommandButton1 If .Caption = "保护工作表" Then Call 保护工作表 .Caption = "取消工作表保护" Exit Sub End If If .Caption = "取消工作表保护" Then Call 取消工作表保护 .Caption = "保护工作表"

     

    087. 在多个宏中依次循环执行一个(控件按钮代码)

         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. 在当前工作组各表中分别执行指定宏

         'northwolves版主解答 http://club.excelhome.net/dispbbs.asp?boardid=2&id=251426&star=2#914934 Sub 在当前工作组各表中分别执行指定宏() Dim SH As Worksheet For Each SH In ActiveWindow.SelectedSheets SH.Activate 临时 N

     

    089. 在当前选区有条件替换数值为文本

         Sub 在当前选区有条件替换数值为文本() For Each r In Selection If r.Value > 18 And r.Value < 29.5 Then r.Value = "Y" Next End Sub

     

    090. 在所有工作表的A1单元返回顺序号

         Sub 在所有工作表的A1单元返回顺序号() For i = 1 To Sheets.Count Sheets(i).Cells(1, 1) = "'" & Application.WorksheetFunction.Text(0 + i, "000") Next End Sub

     

    091. 在指定区域选择单元时数值加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. 在指定单元记录打印和预览次数(工作簿代码)

         Private Sub Workbook_BeforePrint(Cancel As Boolean) Range("A1") = 1 + Range("A1") End Sub

     

     093. 在指定工作表的指定单元返回光标当前多选区地址(工作簿代码)

         Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) Worksheets("表2").Range("A1") = Target.Address(0, 0) End Sub

     

    094. 在有密码的工作表执行代码

         Sub 在有密码的工作表执行代码() 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. 在第一个表前插入多工作表

         Sub 在第一个表前插入多工作表() 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. 处理导入的显示为科学计数法样式的身份证号

         Sub 处理导入的显示为科学计数法样式的身份证号() Selection.Value = Selection.Formula End Sub

     

    099. 复制单元数值

         Sub 复制数值() s = Workbooks("book1").Sheets("Sheet1").Range("A1:A2") Workbooks("book2").Sheets("Sheet1").Range("A1:A2") = s End Sub

     

    100. 复制单元格所在列

         Sub 复制单元格所在列() Selection.EntireColumn.Copy End Sub

     

    101. 复制单元格所在行

         Sub 复制单元格所在行() Selection.EntireRow.Copy End Sub

     

    102. 复制当前工作簿的报表到临时工作簿

         Sub 复制当前工作簿的报表到临时工作簿() '作者: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 Workbook

     

    103. 奇偶页分别打印

         Sub 奇偶页分别打印() Dim i%, Ps% Ps = ExecuteExcel4Macro("GET.DOCUMENT(50)") '总页数 MsgBox "现在打印奇数页,按确定开始." For i = 1 To Ps Step 2 ActiveSheet.PrintOut from:=i, To:=i Next i MsgBox "现在打印偶数页,按确定开始." For

     

     104. 定义指定工作表标签颜色

         Sub 定义指定工作表标签颜色() Sheets("Sheet1").Tab.ColorIndex = 46 End Sub

     

    105. 定位数据及区域以上的空值

         Sub 定位数据及区域以上的空值() 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. 实现删去特定的行

     

         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)为指定的工作表。 这个宏指向的是当前

     

    108. 对指定工作表执行取消隐藏》打印》隐藏工作表

         Sub 打印隐藏工作表() Sheets("报表1").Visible = 1 Sheets("报表1").PrintOut Copies:=1, Collate:=True Sheets("报表1").Visible = 0 End Sub

     

     109. 对第一张工作表的指定区域进行排序

         Sub 对第一张工作表的指定区域进行排序() With Worksheets(1) .Range("a2:a100").Sort Key1:=.Range("a1") End With End Sub

     

    110. 将A1单元录入的数据累加到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列数据排序到D列

         Sub 将A列数据排序到D列() [d:d] = [a:a].Value [d:d].Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes End Sub

     

    112. 将A列数据随机排列到F列

         Sub 将A列数据随机排列到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列最后数据行以上的所有B列图片大小调整为所在单元大小

         Sub 将A列最后数据行以上的所有B列图片大小调整为所在单元大小() 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列数据添加超链接到K列

         Sub 将B列数据添加超链接到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:="点击转到:" &

     

    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的数据写到名称2

         Sub Macro2() Range("位置2") = Range("位置1").Value End Sub

     

    119. 将所选区域文本插入新建文本框

         Sub 将所选区域文本插入新建文本框() For Each rag In Selection n = n & rag.Value & Chr(10) Next ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left + ActiveCell.Width, ActiveCell.Top + Act

     

    120. 将指定范围的数据排列到D列

         Sub 将指定范围的数据排列到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. 将本工作表单独另存文件到Excel当前默认目录

         Sub 将本工作表单独另存文件到Excel当前默认目录() ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name & ".xls" End Sub

     

    122. 将第5行移到窗口的最上面

         Worksheets("Sheet1").Activate ActiveWindow.ScrollRow = 5

     

    123. 工作表中包含数据的最大行数

         Sub 包含数据的最大行数() n = Cells.Find("*", , , , 1, 2).Row MsgBox n End Sub

     

    124. 工作表标签排序

         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

     

    125. 延时15秒执行重排窗口宏

         Sub 延时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. 建立当前工作表的副本为001表

         Sub 建立当前工作表的副本为001表() ActiveSheet.Copy Before:=Sheets(1) ActiveSheet.Name = "001" End Sub

     

    128. 引用指定位置单元内容为部分文件名另存文件

         Sub 引用指定位置单元内容为部分文件名另存文件() ActiveWorkbook.SaveAs Filename:="E:\信件\" & "解答" & Range("sheet1!a1") & "郎雀.xls" End Sub

     

    129. 弹出打印对话框

         Sub 弹出打印对话框() Application.Dialogs(xlDialogPrint).Show End Sub

     

    130. 弹出提示A1单元内容

         Sub 弹出提示A1单元内容() MsgBox "提示" & Range("A1").Value End Sub

     

    131. 强行合并单元

         Sub 强行合并单元() Application.DisplayAlerts = False '不出现对话框,按对话框默认选择Range("a3:a4").Merge Application.ScreenUpdating = True End Sub

     

    132. 当修改指定单元内容时自动执行宏(工作表代码)

         Private Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, [B3:B4]) Is Nothing Then 重排窗口 End If End Sub

     

    133. 当前单元内容返回到按钮名称(控件按钮代码)

         Private Sub CommandButton1_Click() CommandButton1.Caption = ActiveCell End Sub

     

    134. 当前单元加2

         Sub 当前单元加2() Selection = Selection + 2 'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub

     

    135. 当前单元录入计算机名

         Sub 当前单元录入计算机名() Selection = Environ("COMPUTERNAME") 'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub

     

    136. 当前单元录入计算机用户名

         Sub 当前单元录入计算机用户名() Selection = Environ("Username") 'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub

     

    137. 当前单元返回按钮名称(控件按钮代码)

         Private Sub CommandButton1_Click() ActiveCell = CommandButton1.Caption End Sub

     

    138. 当前文件另存到指定目录

         Sub 当前激活文件另存到指定目录() ActiveWorkbook.SaveAs Filename:="E:\信件\" & ActiveWorkbook.Name End Sub

     

    139. 当前行下插入1行

         Sub 当前行下插入1行() Selection.Offset(1, 0).Insert End Sub

     

    140. 当前选区的行列数

         Sub 当前选区的行列数() Range("A1") = Selection.Rows.Count '当前选区的行数 Range("B1") = Selection.Columns.Count '当前选区的列数 End Sub

     

    141. 当指定区域修改时在其右侧的2个单元返回当前日期和时间(工作表代码)

         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. 当指定日期(每月10日)打开文件执行宏

         Sub auto_open() If Day(Date) = 10 Then 重排窗口 End If End Sub

     

    143. 录制宏时调用“停止录制”工具栏

         Sub 录制宏时调用停止录制工具栏() Application.CommandBars("Stop Recording").Visible = True End Sub

     

    144. 循环宏

         Sub 循环() AAA = Range("C2") Dim i As Long Dim times As Long times = AAA 'times代表循环次数,执行前把times赋值即可(不可小于1,不可大于2147483647) For i = 1 To times Call 过滤一行 If Range("完成标志") = "完成" Then Exit For

     

    145. 手动重算

         Sub 手动重算() 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. 打开文件时执行指定宏(工作簿代码)

         Private Sub Workbook_Open() 重排窗口 '要执行的宏名称 End Sub

     

    148. 打开文件时提示指定工作表是保护状态(ThisWorkbook)

         Private Sub Workbook_Open() If Worksheets("Sheet1").ProtectContents = True Then MsgBox " Sheet1保护了." End If End Sub

     

    149. 执行前需要验证密码的宏(控件按钮代码)

         Private Sub CommandButton1_Click() If InputBox("请输入密码:") <> "123" Then '密码是123 MsgBox "密码错误,按确定退出!", 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. 批量插入统一批注

         Sub 批量插入统一批注() 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.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列不重复值取到e列

         Sub 把a列不重复值取到e列() [A:A].AdvancedFilter 2, , [e1], 1 End Sub

     

    155. 拷贝A1公式和格式到A2

         Sub 拷贝A1公式到A2() Workbooks("临时表").Sheets("表1").Range("A1").Copy Workbooks("临时表").Sheets("表2").Range("A2").PasteSpecial End Sub

     

    156. 拷贝指定表不相邻多列数据到新位置

         Sub 拷贝指定表不相邻多列数据到新位置() Sheets("sheet1").Range("A:A,J:J").Copy Range("d1") End Sub

     

    157. 指定允许编辑区域

    Sub 指定允许编辑区域() ActiveSheet.ScrollArea = "B8:G15" End Sub

     

    158. 指定区域单元双击数据累加(工作表代码)

         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. 指定单元显示光标位置内容(工作表代码)

     

         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. 指定选择单元区域弹出消息

         Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$A$1:$C$3" Then MsgBox "你选择对了" End If End Sub

     

    163. 按aa工作表A列的内容排列工作表标签顺序

         Sub 按aa工作表A列的内容排列工作表标签顺序() 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列数据批量修改表名称

         Sub 按A列数据批量修改表名称() Dim i% For i = 1 To Sheets.Count - 1 Sheets(i).Name = Cells(i + 1, 1).Text Next End Sub

     

    165. 按A列数据批量创建新表(控件按钮代码)

         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. 按光标选定颜色隐藏本列其他颜色行

         Sub 按颜色筛选() '思路就是:其它背景色之行全部隐藏 Dim UseRow, AC, i '首先选择一个有颜色之单元格,然后动行宏,其它颜色所在行隐藏 UseRow = Cells.SpecialCells(xlCellTypeLastCell).Row 'SpecialCells(xlCellTypeLastCell)表示已用区域最后一个单元格 If ActiveCell.Row

     

    167. 按固定文本定位

         Sub 文本定位() Dim aa As Range For Each a In ActiveSheet.UsedRange If a Like "*合计*" 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. 按当前单元文本定位

         Sub 按当前单元文本定位() 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. 按当前单元文本选择打开指定文件单元

         Sub 选择打开文件单元() Dim a a = ActiveCell.Value Range(a).Worksheet.Activate Range(a).Select End Sub

     

    170. 按照当前行A列的图片名称插入图片到H列

         Sub 按照当前行A列的图片名称插入图片到H列() AAA = Selection.Row Range("H" & AAA).Select Selection.RowHeight = 37 '指定行高 ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Range("A" & Selection.Row) & ".JPG").S

     

    171. 提示并全部清除当前选择区域

         Sub 提示并全部清除当前选择区域() If MsgBox("你确定要清除选择的区域吗?", vbYesNo, " 提示:") = vbYes Then Selection.Clear End Sub

     

    172. 提示并清空单元区域

         Sub 清空单元区域() If MsgBox("是否真的要清空数据?清除后将无法恢复", 1 + vbokNo) = vbOK Then Range("A1:B10,A15:B25").ClearContents End If End Sub

     

    173. 提示开始和结束

         ?Sub 提示结束() Msgbox "运行开始" ?过程…… Msgbox "运行结束" End Sub

     

    174. 提示确定或取消执行宏

     

         Sub 提示确定或取消执行宏() If vbOK = MsgBox("确定要复制吗?", vbOKCancel) Then Range("A4:A14").Copy Range("b4:b14") Msgbox "复制结束" End If End Sub

     

    175. 插入10行

         Sub 插入10行() Rows(ActiveCell.Row & ":" & ActiveCell.Row + 9).Select Selection.Insert Shift:=xlDown End Sub

     

     

    176. 插入数值条件格式

        Sub 插入数值条件格式() 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. 撤消工作表保护并取消密码

         Sub 撤消工作表保护并取消密码() ActiveSheet.Unprotect Password:=123456 End Sub

      

    179. 改变Excel界面标题的宏(工作簿代码)

         Private Sub Workbook_Open() Application.Caption = "春节快乐" End Sub

     

    180. 新建一个工作簿

         Sub 新建一个工作簿() Workbooks.Add End Sub

     

    181. 新建一个工作表

         Sub 新建一个工作表() Sheets.Add End Sub

     

    182. 显示光标所在单元的批注的代码

         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. 显示指定工作表的打印预览

         Sub 显示指定工作表的打印预览() Worksheets("Sheet1").PrintPreview End Sub

     

    184. 更新透视表数据项

         Sub DeleteMissingItems2002All() '防止数据透视表中显示无用的数据项 '在 Excel 2002 或更高版本中'如果无用的数据项已经存在, '运行这个宏可以更新 Dim pt As PivotTable Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets For Each pt

     

    185. 有条件删除当前行

         Sub 有条件删除当前行() If [A1] = 2 Or [B1] = "删除" Then Selection.Delete Shift:=xlUp End If End Sub

     

    186. 有条件执行不同的宏

         Sub 有条件执行不同的宏() If [b1].Value = "A" Then Application.Run "宏1" ElseIf [b1].Value = "B" Then Application.Run "宏2" End If End Sub

     

    187. 有条件执行宏

         Sub 高级筛选() 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. 朗读固定语句,请按ESC键终止

         Sub 朗读固定语句() On Error Resume Next Application.Speech.Speak "你好,节日快乐。", , , 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. 本示例为设置密码窗口 (1)

         X = MsgBox("是否真的要结帐?", 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 '当前文件名称 Sh

     

    192. 查找A列文本循环插入分页符

         Sub 循环插入分页符() ' Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 Dim i As Long Dim times As Long times = Application.WorksheetFunction.CountIf(Sheet1.Range("a:a"), "分页") 'times代表循

     

    193. 根据A1内容选择执行宏

         Sub 根据A1内容选择执行宏() Select Case Sheet1.[A1] Case "A" 宏1 Case "B" 宏2 Case "C" 宏3 Case Else End Select End Sub

     

    194. 根据A1单元内容返回C1数值

         Sub 根据A1单元内容返回C1数值() If Range("A1") = "A" Then Range("C1").FormulaR1C1 = "结算" ElseIf Range("A1") = "B" Then Range("C1").FormulaR1C1 = "合计" ElseIf Range("A1") = "C" Then Range("C1").FormulaR1C1

     

    195. 根据B列最后数据快速合并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. 每编辑一个单元保存文件

         Private Sub Worksheet_Change(ByVal Target As Range) ThisWorkbook.Save End Sub

     

    197. 深度隐藏指定工作表

         Sub 深度隐藏指定工作表() Sheets("用户名密码").Visible = xlVeryHidden End Sub

     

    198. 混合文本的编号

         Sub 混合文本的编号() Worksheets(1).Range("B2").Value = "北京" & (--(Mid(Worksheets(1).Range("B2"), 3, 100)) + 1) End Sub

     

    199. 添加文本

         Sub 添加文本() Selection = Selection + "×" '不可在数字后添加文本 'Selection = Workbooks("临时表").Sheets("表2").Range("A1") 调用指定地址内容 End Sub

     

    200. 添加自定义序列

         Sub 添加自定义序列() Application.AddCustomList ListArray:=Array("优","良", "中", "差","劣") End Sub

     

    201. 清除A列再插入序号

         Sub 清除A列再插入序号() 'Columns(1).ClearContents '清除A列内容 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. 清除指定区域数值

         Sub 清除单元数值() Sheet1.[A1:A10].ClearContents End Sub Sub 清除指定区域数值() Range("A1:C8") = ClearContents End Sub Sub 清除指定区域数值() Sheet1.[A1:A10]="" End Sub

     

    204. 焦点到A列时运行宏的代码

         Private Sub Worksheet_SelectionChange(ByVal Target As Range) ??? If Target.Column = 1 Then 宏名??? End If End Sub

     

    205. 用于光标选定多区域跳转指定单元(工作表代码)

         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的内容作为文件名另存当前工作簿

         Sub b() ActiveWorkbook.SaveCopyAs Range("A1") + ".xls" End Sub

     

     207. 统计不同颜色的数字的和(自定义函数)

         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 '统计红色,输入:=COLOR(B2:B8,3) '统计蓝色,输入:=COLOR(B2:B8,5)

     

    208. 统计指定范围和内容的单元数量

         Sub 统计指定范围和内容的单元数量() x = Application.WorksheetFunction.CountIf(Range("A3:B100"), "总计") Range("B1") = x End Sub

     

    209. 自动打印多工作表第一页

         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(s

     

    210. 自动数字金额转大写(工作表代码)   

    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, "负" & A & b & c, A & b & c))

    End Function

    211. 自动筛选全部显示指定列

     

         Sub 自动筛选全部显示指定列() Selection.AutoFilter Field:=1 Selection.AutoFilter Field:=2 Selection.AutoFilter Field:=3 Selection.AutoFilter Field:=4 Selection.AutoFilter Field:=5 Selection.AutoFilter Fiel

     

    212. 自动筛选第2列值为A的行

         Sub 自动筛选第2列值为A的行() [a1].AutoFilter 2, "a" End Sub

     

    213. 自动重算

         Sub 自动重算() With Application .Calculation = xlAutomatic End With End Sub

     

    214. 获取上一次所进入工作簿的工作表名称

         Sub 获取上一次所进入工作簿的工作表名称() MsgBox Workbooks(2).ActiveSheet.Name End Sub

     

    215. 被指定单元内容限制执行宏

         Sub 被指定单元限制执行宏() If Range("$A$1") = "关闭" Then Exit Sub 窗口 End Sub

     

    216. 解除允许编辑区域限制

         Sub 解除允许编辑区域限制() ActiveSheet.ScrollArea = "" End Sub

     

    217. 解除全部工作表保护

         Sub 解除全部工作表保护() Dim n As Integer ??? For n = 1 To Sheets.Count ??????? Sheets(n).Unprotect ??? Next n End Sub

     

    218. 设置单元区域格式

         Sub 设置单元区域格式() [a:a].NumberFormat = "yyyy.mm.dd" Sheet2.[B:B].NumberFormatLocal = "yyyy-m-d" Sheet2.[C:C].NumberFormatLocal = "G/通用格式" End Sub

     

    219. 调整选中对象中的文字

         Sub 调整选中对象中的文字() '文字居中、自动调整大小 With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .ReadingOrder = xlContext .Orientation = xlHorizontal .AutoSize = True .AddIndent =

     

    220. 返回A列数据的最大行数

         Sub 返回A列数据的最大行数() n = Range("a65536").End(xlUp).Row Range("B1") = n End Sub

     

    221. 返回A列最后一个非空单元行号

         Sub 返回A列最后非空单元行号() MsgBox Cells.Range("A65536").End(xlUp).Row End Sub

     

    222. 返回A列非空单元数量

         Sub 返回A列非空单元数量() y = Application.CountA(Columns(1)) MsgBox y End Sub

     

    223. 返回光标所在行号

         Sub 返回光标所在行号() Range("A1") = Selection.Row End Sub

     

    224. 返回光标所在行数

         Sub 返回光标所在行数() x = ActiveCell.Row Range("A1") = x End Sub

     

    225. 返回光标选择区域的行数和列数

         Sub 返回光标选择区域的行数和列数() 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. 返回当前单元地址

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

     

    228. 返回当前工作簿中工作表数量

         Sub 返回当前工作簿中工作表数量() t = Application.Sheets.Count MsgBox t End Sub

     

    229. 返回当前工作表名称

         Sub 返回当前工作表名称() wsName = ActiveSheet.Name MsgBox "当前工作表为:" & 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行最右边非空单元的列号

         Sub 返回第1行最右边非空单元的列号() X = [IV1].End(xlToLeft).Column MsgBox X End Sub

     

     233. 返回第一个数值行号

         Sub 返回第一个数值行号() MsgBox [b:b].SpecialCells(2, 1).Row End Sub

     

     234. 返回表中各非空单元区域地址(行搜索)

         Sub 返回表中各非空单元区域地址() MsgBox Cells.SpecialCells(2).Address End Sub

     

    235. 返回表中第一个非空单元地址(行搜索)

         Sub 返回表中第一个非空单元地址() MsgBox Cells.Find("*").Address End Sub

     

    236. 返回连续数值单元的数量

         Sub 返回连续数值单元的数量() MsgBox [b:b].SpecialCells(2, 1).Rows.Count End Sub

     

    237. 返回非空单元数量

         Sub 返回非空单元数量() x = Application.CountA(Range("A1:Z65536")) MsgBox x End Sub

     

    238. 进入单元执行宏(工作表代码)

         Private Sub Worksheet_SelectionChange(ByVal Target As Range) '以单元格进入代替按钮对象调用宏 If Range("$A$1") = "关闭" Then Exit Sub Select Case Target.Address Case "$A$5" '单元地址(Target.Address),或命名单元名字(Target.Nam

     

    239. 进入指定区域单元执行宏(工作表代码)

         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

     

    240. 连续区域录入当前单元地址

         Sub 连续区域录入当前单元地址() 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. 选择光标或选区所在列

         Sub 选择光标或选区所在列() Selection.EntireColumn.Select End Sub

     

    244. 选择光标或选区所在行

         Sub 选择光标或选区所在行() Selection.EntireRow.Select End Sub

     

    245. 选择到指定列的最后行

         Sub 选择到指定列的最后行() Range("C4:G" & [G65536].End(xlUp).Row).Select End Sub

     

    246. 选择单元区域触发事件(工作表代码)

         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. 选择名称定义的数据区

         Sub 选择名称定义的数据区() [数据区].Select '插入名称要使用INDIRECT函数 'Range("数据区").Select或者 'Sheet1.Range("数据区").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 '取得工作表总数 ReDim arr(1 To sh

     

    249. 选择第5行开始所有数据行

         Sub 选择第5行开始所有数据行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("传送参数").Calculate Worksheets("目录").Calculate End Sub

     

    252. 闹钟——到指定时间执行宏(工作簿代码)

     

         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. 隐藏当前工作表

         Sub 隐藏当前工作表() 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. 高级筛选5列不重复数据至指定表

         Sub 高级筛选5列不重复数据至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 大写金额()
    Function dx(q)
       ybb = Round(q * 100)
       y = Int(ybb / 100)
       j = Int(ybb / 10) - y * 10
       f = ybb - y * 100 - j * 10
       zy = Application.WorksheetFunction.Text(y, "[dbnum2]")
       zj = Application.WorksheetFunction.Text(j, "[dbnum2]")
       zf = Application.WorksheetFunction.Text(f, "[dbnum2]")
       dx = zy & "元" & "整"
       dl = zy & "元"
       If f <> 0 And j <> 0 Then
         dx = dl & zj & "角" & zf & "分"
         If y = 0 Then
             dx = zj & "角" & zf & "分"
             End If
           End If
       If f = 0 And j <> 0 Then
         dx = dl & zj & "角" & "整"
         If y = 0 Then
             dx = zj & "角" & "整"
             End If
        End If
        If f <> 0 And j = 0 Then
        dx = dl & zj & zf & "分"
        If y = 0 Then
          dx = zf & "分"
          End If
        End If
        If q = "" Then
          dx = 0
           End If
          End Function
    Sub baoxiao()
    End Sub

    展开全文
  • 唯一能做的就是破解,但网上各种破解工具又不可靠,各种担心,好不...利用宏运行方式破解,真的很有效,运行中可能电脑会有两分钟无反应,千萬不要以为死机了哦,等一等! 步骤方法如下: 打开文件 工具—宏—-...

    各位朋友估计都经历过excel 设置了密码,N久以后本以为这辈子都不会忘记的密码,真的忘记了。

    唯一能做的就是破解,但网上各种破解工具又不可靠,各种担心,好不容易鼓起勇气决定下载破解软件,结果一次次中招,密码没有破解,自己中毒不浅。。。

    只能自己想办法了!利用宏运行方式破解,真的很有效,运行中可能电脑会有两分钟无反应,千萬不要以为死机了哦,等一等!

    步骤方法如下:

    1. 打开文件
    2. 工具—宏—-录制新宏—输入名字如:【W搞密码W】
    3. 停止录制(这样得到一个空宏)
    4. 工具—宏—-宏,选【W搞密码W】,点【编辑】按钮
    5. 删除窗口中的所有字符(只有几个),替换为下面的内容:(复制以下代码)
    6. 关闭编辑窗口
    7. 工具—宏—–宏,选【AllInternalPasswords】,【运行】,确定两次,注意看一下两次确定,会显示密码内容
      等2分钟,再确定.OK,没有密码了! !
      宏程序代码内容如下:

     Public Sub AllInternalPasswords()
     ' Breaks worksheet and workbook structure passwords. Bob McCormick
     ' probably originator of base code algorithm modified for coverage
     ' of workbook structure / windows passwords and for multiple passwords
     '
     ' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1)
     ' Modified 2003-Apr-04 by JEM: All msgs to constants, and
     ' eliminate one Exit Sub (Version 1.1.1)
     ' Reveals hashed passwords NOT original passwords
     Const DBLSPACE As String = vbNewLine & vbNewLine
     Const AUTHORS As String = DBLSPACE & vbNewLine & _
     "Adapted from Bob McCormick base code by" & _
     "Norman Harker and JE McGimpsey"
     Const HEADER As String = "AllInternalPasswords User Message"
     Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04"
     Const REPBACK As String = DBLSPACE & "Please report failure " & _
     "to the microsoft.public.excel.programming newsgroup."
     Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _
     "now be free of all password protection, so make sure you:" & _
     DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _
     DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _
     DBLSPACE & "Also, remember that the password was " & _
     "put there for a reason. Don't stuff up crucial formulas " & _
     "or data." & DBLSPACE & "Access and use of some data " & _
     "may be an offense. If in doubt, don't."
     Const MSGNOPWORDS1 As String = "There were no passwords on " & _
     "sheets, or workbook structure or windows." & AUTHORS & VERSION
     Const MSGNOPWORDS2 As String = "There was no protection to " & _
     "workbook structure or windows." & DBLSPACE & _
     "Proceeding to unprotect sheets." & AUTHORS & VERSION
     Const MSGTAKETIME As String = "After pressing OK button this " & _
     "will take some time." & DBLSPACE & "Amount of time " & _
     "depends on how many different passwords, the " & _
     "passwords, and your computer's specification." & DBLSPACE & _
     "Just be patient! Make me a coffee!" & AUTHORS & VERSION
     Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _
     "Structure or Windows Password set." & DBLSPACE & _
     "The password found was: " & DBLSPACE & "$$" & DBLSPACE & _
     "Note it down for potential future use in other workbooks by " & _
     "the same person who set this password." & DBLSPACE & _
     "Now to check and clear other passwords." & AUTHORS & VERSION
     Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _
     "password set." & DBLSPACE & "The password found was: " & _
     DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _
     "future use in other workbooks by same person who " & _
     "set this password." & DBLSPACE & "Now to check and clear " & _
     "other passwords." & AUTHORS & VERSION
     Const MSGONLYONE As String = "Only structure / windows " & _
     "protected with the password that was just found." & _
     ALLCLEAR & AUTHORS & VERSION & REPBACK
     Dim w1 As Worksheet, w2 As Worksheet
     Dim i As Integer, j As Integer, k As Integer, l As Integer
     Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
     Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
     Dim PWord1 As String
     Dim ShTag As Boolean, WinTag As Boolean
    
    Application.ScreenUpdating = False
     With ActiveWorkbook
     WinTag = .ProtectStructure Or .ProtectWindows
     End With
     ShTag = False
     For Each w1 In Worksheets
     ShTag = ShTag Or w1.ProtectContents
     Next w1
     If Not ShTag And Not WinTag Then
     MsgBox MSGNOPWORDS1, vbInformation, HEADER
     Exit Sub
     End If
     MsgBox MSGTAKETIME, vbInformation, HEADER
     If Not WinTag Then
     MsgBox MSGNOPWORDS2, vbInformation, HEADER
     Else
     On Error Resume Next
     Do 'dummy do loop
     For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
     For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
     For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
     For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
     With ActiveWorkbook
     .Unprotect Chr(i) & Chr(j) & Chr(k) & _
     Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
     Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
     If .ProtectStructure = False And _
     .ProtectWindows = False Then
     PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
     Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
     Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
     MsgBox Application.Substitute(MSGPWORDFOUND1, _
     "$$", PWord1), vbInformation, HEADER
     Exit Do 'Bypass all for...nexts
     End If
     End With
     Next: Next: Next: Next: Next: Next
     Next: Next: Next: Next: Next: Next
     Loop Until True
     On Error GoTo 0
     End If
     If WinTag And Not ShTag Then
     MsgBox MSGONLYONE, vbInformation, HEADER
     Exit Sub
     End If
     On Error Resume Next
     For Each w1 In Worksheets
     'Attempt clearance with PWord1
     w1.Unprotect PWord1
     Next w1
     On Error GoTo 0
     ShTag = False
     For Each w1 In Worksheets
     'Checks for all clear ShTag triggered to 1 if not.
     ShTag = ShTag Or w1.ProtectContents
     Next w1
     If ShTag Then
     For Each w1 In Worksheets
     With w1
     If .ProtectContents Then
     On Error Resume Next
     Do 'Dummy do loop
     For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
     For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
     For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
     For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
     .Unprotect Chr(i) & Chr(j) & Chr(k) & _
     Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
     Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
     If Not .ProtectContents Then
     PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
     Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
     Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
     MsgBox Application.Substitute(MSGPWORDFOUND2, _
     "$$", PWord1), vbInformation, HEADER
     'leverage finding Pword by trying on other sheets
     For Each w2 In Worksheets
     w2.Unprotect PWord1
     Next w2
     Exit Do 'Bypass all for...nexts
     End If
     Next: Next: Next: Next: Next: Next
     Next: Next: Next: Next: Next: Next
     Loop Until True
     On Error GoTo 0
     End If
     End With
     Next w1
     End If
     MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER
     End Sub
    

     

    展开全文
  •  3、停止录制(这样得到一个空);  4、依次点击菜单栏上的工具-------,选aa,点编辑按钮;    5、删除窗口中的所有字符(只有几个),替换为下面的内容;   从横线下开始复制 -------------------...

    转载自:http://club.excelhome.net/thread-640179-1-1.html

    在日常工作中,您是否遇到过这样的情况:您用Excel编制的报表、表格、程序等,在单元格中设置了公式、函数等,为了防止其他人修改您的设置或者防止您自己无意中修改,您可能会使用Excel的工作表保护功能,但时间久了保护密码容易忘记,这该怎么办?有时您从网上下载的Excel格式的小程序,您想修改,但是作者加了工作表保护密码,怎么办?您只要按照以下步骤操作,Excel工作表保护密码瞬间即破!

        1、打开您需要破解保护密码的Excel文件;
        2、依次点击菜单栏上的工具---宏----录制新宏,输入宏名字如:aa;
        3、停止录制(这样得到一个空宏);
        4、依次点击菜单栏上的工具---宏----宏,选aa,点编辑按钮;

     

        5、删除窗口中的所有字符(只有几个),替换为下面的内容;

     

    从横线下开始复制
    ------------------------------------------------------------------------------------------
    Option Explicit

    Public Sub AllInternalPasswords() 
    ' Breaks worksheet and workbook structure passwords. Bob McCormick 
    ' probably originator of base code algorithm modified for coverage 
    ' of workbook structure / windows passwords and for multiple passwords 

    ' Norman Harker and JE McGimpsey 27-Dec-2002 (Version 1.1) 
    ' Modified 2003-Apr-04 by JEM: All msgs to constants, and 
    ' eliminate one Exit Sub (Version 1.1.1) 
    ' Reveals hashed passwords NOT original passwords 
    Const DBLSPACE As String = vbNewLine & vbNewLine 
    Const AUTHORS As String = DBLSPACE & vbNewLine & _ 
    "Adapted from Bob McCormick base code by" & _ 
    "Norman Harker and JE McGimpsey" 
    Const HEADER As String = "AllInternalPasswords User Message" 
    Const VERSION As String = DBLSPACE & "Version 1.1.1 2003-Apr-04" 
    Const REPBACK As String = DBLSPACE & "Please report failure " & _ 
    "to the microsoft.public.excel.programming newsgroup." 
    Const ALLCLEAR As String = DBLSPACE & "The workbook should " & _ 
    "now be free of all password protection, so make sure you:" & _ 
    DBLSPACE & "SAVE IT NOW!" & DBLSPACE & "and also" & _ 
    DBLSPACE & "BACKUP!, BACKUP!!, BACKUP!!!" & _ 
    DBLSPACE & "Also, remember that the password was " & _ 
    "put there for a reason. Don't stuff up crucial formulas " & _ 
    "or data." & DBLSPACE & "Access and use of some data " & _ 
    "may be an offense. If in doubt, don't." 
    Const MSGNOPWORDS1 As String = "There were no passwords on " & _ 
    "sheets, or workbook structure or windows." & AUTHORS & VERSION 
    Const MSGNOPWORDS2 As String = "There was no protection to " & _ 
    "workbook structure or windows." & DBLSPACE & _ 
    "Proceeding to unprotect sheets." & AUTHORS & VERSION 
    Const MSGTAKETIME As String = "After pressing OK button this " & _ 
    "will take some time." & DBLSPACE & "Amount of time " & _ 
    "depends on how many different passwords, the " & _ 
    "passwords, and your computer's specification." & DBLSPACE & _ 
    "Just be patient! Make me a coffee!" & AUTHORS & VERSION 
    Const MSGPWORDFOUND1 As String = "You had a Worksheet " & _ 
    "Structure or Windows Password set." & DBLSPACE & _ 
    "The password found was: " & DBLSPACE & "$$" & DBLSPACE & _ 
    "Note it down for potential future use in other workbooks by " & _ 
    "the same person who set this password." & DBLSPACE & _ 
    "Now to check and clear other passwords." & AUTHORS & VERSION 
    Const MSGPWORDFOUND2 As String = "You had a Worksheet " & _ 
    "password set." & DBLSPACE & "The password found was: " & _ 
    DBLSPACE & "$$" & DBLSPACE & "Note it down for potential " & _ 
    "future use in other workbooks by same person who " & _ 
    "set this password." & DBLSPACE & "Now to check and clear " & _ 
    "other passwords." & AUTHORS & VERSION 
    Const MSGONLYONE As String = "Only structure / windows " & _ 
    "protected with the password that was just found." & _ 
    ALLCLEAR & AUTHORS & VERSION & REPBACK 
    Dim w1 As Worksheet, w2 As Worksheet 
    Dim i As Integer, j As Integer, k As Integer, l As Integer 
    Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer 
    Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer 
    Dim PWord1 As String 
    Dim ShTag As Boolean, WinTag As Boolean

    Application.ScreenUpdating = False 
    With ActiveWorkbook 
    WinTag = .ProtectStructure Or .ProtectWindows 
    End With 
    ShTag = False 
    For Each w1 In Worksheets 
    ShTag = ShTag Or w1.ProtectContents 
    Next w1 
    If Not ShTag And Not WinTag Then 
    MsgBox MSGNOPWORDS1, vbInformation, HEADER 
    Exit Sub 
    End If 
    MsgBox MSGTAKETIME, vbInformation, HEADER 
    If Not WinTag Then 
    MsgBox MSGNOPWORDS2, vbInformation, HEADER 
    Else 
    On Error Resume Next 
    Do 'dummy do loop 
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 
    With ActiveWorkbook 
    .Unprotect Chr(i) & Chr(j) & Chr(k) & _ 
    Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ 
    Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 
    If .ProtectStructure = False And _ 
    .ProtectWindows = False Then 
    PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ 
    Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 
    Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 
    MsgBox Application.Substitute(MSGPWORDFOUND1, _ 
    "$$", PWord1), vbInformation, HEADER 
    Exit Do 'Bypass all for...nexts 
    End If 
    End With 
    Next: Next: Next: Next: Next: Next 
    Next: Next: Next: Next: Next: Next 
    Loop Until True 
    On Error GoTo 0 
    End If 
    If WinTag And Not ShTag Then 
    MsgBox MSGONLYONE, vbInformation, HEADER 
    Exit Sub 
    End If 
    On Error Resume Next 
    For Each w1 In Worksheets 
    'Attempt clearance with PWord1 
    w1.Unprotect PWord1 
    Next w1 
    On Error GoTo 0 
    ShTag = False 
    For Each w1 In Worksheets 
    'Checks for all clear ShTag triggered to 1 if not. 
    ShTag = ShTag Or w1.ProtectContents 
    Next w1 
    If ShTag Then 
    For Each w1 In Worksheets 
    With w1 
    If .ProtectContents Then 
    On Error Resume Next 
    Do 'Dummy do loop 
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 
    .Unprotect Chr(i) & Chr(j) & Chr(k) & _ 
    Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 
    Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 
    If Not .ProtectContents Then 
    PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ 
    Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ 
    Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) 
    MsgBox Application.Substitute(MSGPWORDFOUND2, _ 
    "$$", PWord1), vbInformation, HEADER 
    'leverage finding Pword by trying on other sheets 
    For Each w2 In Worksheets 
    w2.Unprotect PWord1 
    Next w2 
    Exit Do 'Bypass all for...nexts 
    End If 
    Next: Next: Next: Next: Next: Next 
    Next: Next: Next: Next: Next: Next 
    Loop Until True 
    On Error GoTo 0 
    End If 
    End With 
    Next w1 
    End If 
    MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK, vbInformation, HEADER 
    End Sub
    -----------------------------------------------------------------------------------------
    复制到横线以上
        6、关闭编辑窗口;
        7、依次点击菜单栏上的工具---宏-----宏,选AllInternalPasswords,运行,确定两次; 
        等一会,就会出现以下对话框:这就是Excel密码对应的原始密码(此密码和原先设置的密码都能打开此文档。如果是别人的文档,你又想恢复密码设置,就可以用此密码进行保护,他就能用他设置的密码打开,你可以试试,很有趣的。字母一定要大写):

    展开全文
  • 在 Excel 启动时运行宏

    千次阅读 2012-08-31 16:41:06
    如果您希望每当启动 Microsoft Excel 时都自动执行某些操作,可以录制或编写一个每当打开工作簿时都将运行。有两个办法可以做到这一点: 录制一个,然后用 Auto_Open 这一名称保存它。 将此编写为工作簿...
  • CorelDRAW 编写和运行宏指令

    千次阅读 2010-06-06 17:53:00
    CorelDRAW 编写和运行宏指令 开发和运行 CorelDRAW 指令之前,必须安装 VBA 组件。 <br />安装 CorelDRAW VBA VBA 在 CoerlDRAW 11和12 中是作为典型安装的一部分安装。CoerlDRAW 10 中,VBA...
  • Excel的介绍及应用

    千次阅读 2020-06-15 23:21:07
    录制: Excel提供了可以像录制声音那样录制代码段,点击“录制”之后,接下来对Excel的操作会自动转换为代码的来源 既然是可以重复执行的代码段,那是什么语言的代码呢?答案是VBA, 那VBA是什么...
  • 侦听OBTP预订事件以在端点上开始/停止,并根据预订的会议自动开始和停止会议。 在注册到Webex团队的DX80上进行了测试。 支持工具 支持工具是一个菜单,可以添加到您的系统中,以允许用户通过呼叫或通过简短电子...
  • 使用宏代码实现的快速合并单元格   1 在菜单栏“视图”选项卡,点击“”下拉列表“录制”。 2 此时,在弹出的“录制新宏”窗口中,设置宏名、快捷键和保存在的工作薄。(快捷键不...
  • 用matlab画长方体代码Solidworks教程 在本教程中,我将展示如何使用VB.net制作.exe文件的过程。 因为互联网上的信息很少。 所以我决定写一个。 其他许多教程也讲授了录制的方法,以及在Solidworks上运行宏的方法...
  • C++定义详解

    千次阅读 2014-10-08 22:06:09
     #define是C语言中提供的定义命令,其主要目的是为程序员在编程时提供一定的方便,并能在一定程度上提高程序的运行效率,但学生在学习时往往不能 理解该命令的本质,总是在此处产生一些困惑,在编程时误用该命令...
  • 我们在计算机中写的.c文件,被称为C语言源代码,这种源代码机器是不认识的,为了让机器认识C语言源代码,那么必须要经过这么几个过程(预处理、编译、汇编、链接、加载),让源代码变为机器语言的目标文件,才可以...
  • 【C语言】----定义,预处理

    千次阅读 多人点赞 2019-09-26 21:55:28
    是学习任何语言所不可缺少的,优秀的定义可以使得代码变得很简洁且高效,有效地提高编程效率。 是一种预处理指令,它提供了一种机制,可以用来替换源代码中的字符串,解释器或编译器在遇到宏时会自动进行这一...
  • EXCEL的录制

    千次阅读 2019-04-19 10:21:36
    SAP的DOI和OLE操作往往会涉及到对EXCEL模板中宏的调用,的调用,实际上是对某段VBA代码的调用,而VBA代码是可以使用录制功能自动生成的,以下简单介绍的录制。 在视图选项下,就是录制和宏查看的入口,如下...
  • 录制

    千次阅读 2018-10-01 20:24:20
    1、的介绍:  是能够自动完成某项... Excel能够将用户在Excel中的操作过程记录下来,并自动形成代码。这个过程就是录制的过程。 3、具体操作:  例如在excel的固定位置总是会输入固定的一些值,这种情...
  • 同时按Alt和F11进入VB界面,在左上窗口找到模块一,双击,右边窗口出来了你录制的代码。懂英语最好了,一句一句就象白话文:) 回到Excel中,选中A1到B1,编辑,清除内容和格式。工具,运行宏,看看变化。 ...
  • 的使用

    千次阅读 2013-11-19 16:05:17
    该词汇使用范围目前比较广泛,例如,微软把 Office 系列产品中的 VBA 脚本代码也使用宏来指称;一些其他软件也会把某些执行动作的序列录制为脚本,称之为(例如常用的文本编辑器UltraEdit );在汇编语言...
  • 前文从总结基于机器学习的恶意代码检测技术,主要参考郑师兄的视频总结,包括机器学习概述与算法举例、基于机器学习方法的恶意代码检测、机器学习算法在工业界的应用。这篇文章将尝试软件来源分析,结合APT攻击中...
  • 揭开的神秘面纱:什么是,为什么使用?  您是否曾经在 Microsoft Office 程序中的重复任务上花费了太多的时间?有没有想过可能有更好的办法?也许您需要在一个 Word 长文档中重新设置许多表格的格式,在...
  • [ C/C++ ] 程序学习--如何阅读别人的代码 ++++++++++++ 第一章: 导论 ++++++++++++ 1.要养成一个习惯, 经常花时间阅读别人编写的高品质代码. 2.要有选择地阅读代码, 同时, 还要有自己的目标. 您是想...
  • 本课程将教您如何构建可重用的Rust代码,以便停止复制粘贴代码。 编写一个可以适应多种不同用法的代码。 您将通过使用“特征”,“泛型”和“”等高级功能来重用代码。 您将使用不同形式的代码重用,循环,映射,...
  • Access学习总结

    万次阅读 2017-03-20 18:00:13
    详细了解access中的 什么是  到底什么是呢? 我们把那些能自动执行某种操作的命令统称为“”。  也是一种操作命令,它和菜单操作命令都是一样的,只是它们对数据库施加作用的时间有所不同,作用...
  • 因此,我重新开设了这个专栏,准备系统整理和深入学习系统安全、逆向分析和恶意代码检测,“系统安全”系列文章会更加聚焦,更加系统,更加深入,也是作者的慢慢成长史。换专业确实挺难的,逆向分析也是块硬骨头,但...
  • 破解Excel的密码

    千次阅读 2015-06-23 14:26:28
    重要的报表时常有密码保护,与报表...3\停止录制(这样得到一个空) 4\工具-------,选aa,点编辑按钮 5\删除窗口中的所有字符(只有几个),替换为下面的内容:(复制吧) 6\关闭编辑窗口 7\工具--------,选AllIntern
  • VS 2010 IDE 学习总结

    千次阅读 2016-12-06 15:22:39
     在敲代码的过程中类和函数都需要进行注释,但总是一遍一遍的复制粘贴觉得很是麻烦,终于找到 了一个不错的解决方法:使用。  所谓,就是一些命令组织在一起,作为一个单独命令完成一个特定任务。在日常的...
  • FOC和SVPWM的C语言代码实现

    万次阅读 多人点赞 2019-07-09 23:09:41
    现在开始分析C语言的代码代码建议复制到notepad++中查看),为方便读者试验,每个代码都是独立的子模块,复制到工程中就可以编译运行: 一、配置高级定时器TIM1产生6路互补PWM,带刹车保护 详细配置代码如下,把...
  • Excel教程 (的介绍与基本使用)

    万次阅读 2013-06-09 08:39:25
    Excel教程 (的介绍与基本使用) Microsoft excel是一款功能非常强大的电子表格软件。它可以轻松地完成数据的各类数学运算,并用各种二维或三维图形形象地表示出来,从而大大简化了数据的处理工作。但若仅...
  • 定义 使用技巧总结

    千次阅读 2013-06-23 16:18:38
    我在写代码的时候喜欢使用,不仅使代码看起来整洁,而且用好了还能极大的减轻编码的工作量,但是如果使用不当的话,出了问题查找起来就就非常的难了,下面的总结大部分是从网上看到的,也有一些是我自己在工作中...
  • 定义

    千次阅读 2009-06-18 11:43:00
    在源流程序被编译器处理之前, 预处理器首先对源程序中的"(macro)"进行处理. C初学者可能对预处理器没什么概念, 这是情有可原的: 一般的C编译器都将预处理, 汇编, 编译, 连接过程集成到一起了. 编译预处理往往在...
  • 如何阅读源代码

    千次阅读 2014-04-28 18:50:55
    2.要有选择地阅读代码, 同时, 还要有自己的目标. 您是想学习新的模式|编码风格|还是满足某些需求的方法. 3.要注意并重视代码中特殊的非功能性需求, 这些需求也许会导致特殊的实现风格. 4.在现有的代码上工作时...

空空如也

空空如也

1 2 3 4 5 ... 20
收藏数 36,355
精华内容 14,542
关键字:

停止宏运行的代码