Word 宏命令大全

1、   为宏命令指定快捷键。在WORD中，操作可以通过菜单项或工具栏按钮实现，如果功能项有对应的快捷键的话，利用快捷键可以快速实现我们需要的功能。如最常见的CTRL＋O、CTRL＋A等等。WORD已经为很多功能指定了快捷键，可以大大提高WORD的操作速度，比用鼠标操作快捷很多。

而我们自己编辑或者录制的宏，可以用菜单项操作完成，也可以为这些命令设置按钮，通过工具栏按钮操作，如果为这些常用的宏指定合适的快捷键，会为我们提供很大的便利。

如何为功能项设置快捷键或修改功能项已有的快捷键，需要对 WORD进行自定义设置。在WORD主界面中，点击“工具”菜单下的“自定义”菜单项， 在“自定义”对话框中，点击“键盘”，如下图所示：

2、   举例说明WORD打开状态下，按ALT＋F11，打开VBA编辑器，粘贴如下代码

Sub 英文引号转中文双引号()'Selection.Find.ClearFormattingSelection.Find.Replacement.ClearFormattingWith Selection.Find.Text = """".Forward = True.Wrap = wdStop.MatchByte = TrueEnd WithWith SelectionWhile .Find.Execute.Text = ChrW(8220).Find.Execute.Text = ChrW(8221)WendEnd WithEnd Sub

保存后，再打开“自定义”等命令可以出现下图：

这时按你要指定的快捷键，一一般要跟CTRL、ALT和SHIFT结合，可选取一个两个或者三个，再加上某一个字母。上例我为选定的宏指定的快捷键为ALT+"，因为"与'是在同一键上，实际操作是按三个键。如果“目前指定到”项为[未指定]，选择是保存常规模板“NORMAL”还是本文档，点“指定”，然后关闭。每次按ALT+"，就会执行这段VBA命令。

3、   指定快捷键，尽量不要使用WORD已经使用的快捷键，如果一定使用，那么该快捷键将不再指定给原有的功能命令。指定的快捷键要方便记忆，要有一定的规律。4、如果对WORD默认为功能命令指定的快捷键或自己指定的快捷键不满意，可以进入“自定义键盘”对话框，在“当前快捷键”列表中，选中要删除的快捷键，此时“删除”按钮被激活，点击“删除”，指定的功能命令的快捷键就被删除了。

也可为符号和样式指定快捷，这里不再多说了，下面就放几段宏命令。如有错误，务必指出。如有侵权，请告知，马上删除。

常规设置下标的过程：输入，选定，设定下标，取消选定，设置非下标，继续输入。下面的命令设置光标前一个字符为下标，并继续输入时保持设置前的格式。后面的例子不再解释。Sub Macro1()'' Macro1 Macro' 设置光标前一个字符为下标,快捷键为"Alt+="'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtendSelection.Font.Subscript = TrueSelection.MoveRight Unit:=wdCharacter, Count:=1Selection.Font.Subscript = FalseEnd Sub

Sub Macro9()'' Macro9 Macro' 设置光标前一个字符为上标,快捷键为"Alt++"'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtendSelection.Font.Superscript = TrueSelection.MoveRight Unit:=wdCharacter, Count:=1Selection.Font.Superscript = FalseEnd Sub

Sub Macro2()'' Macro2 Macro' 设置光标前一个字符为斜体,快捷键为"Alt+I"'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtendSelection.Font.Italic = TrueSelection.Font.NameOther = "Times New Roman"Selection.MoveRight Unit:=wdCharacter, Count:=1Selection.Font.Italic = False

End Sub

Sub Macro5()'' Macro5 Macro' 调整中西文字符间距,快捷键为"Alt+J"'If Selection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = False ThenSelection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = TrueElseSelection.ParagraphFormat.AddSpaceBetweenFarEastAndAlpha = FalseEnd If

End Sub

Sub Macro4()'' Macro4 Macro' 设置光标前一个文字加着重号,快捷键为"Alt+."'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtendSelection.Font.EmphasisMark = wdEmphasisMarkUnderSolidCircleSelection.MoveRight Unit:=wdCharacter, Count:=1Selection.Font.EmphasisMark = wdEmphasisMarkNoneEnd Sub

Sub Macro10()'' Macro10 Macro' 调整中文和数字符间距,快捷键为"Alt+N"'If Selection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = False ThenSelection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = TrueElseSelection.ParagraphFormat.AddSpaceBetweenFarEastAndDigit = FalseEnd IfEnd Sub

设置分式的宏命令：A为分子，B为分母，输入A,B（注意AB之间的逗号为英文逗号）。如果分子是ABC，分母是DG，输入ABC,DG按住SHIFT，按左方向键，选定刚才输入的字符，留3个不选，执行下面的命令。

Sub 分式()'' 分式 Macro' 设置选定分数,快捷键为"Alt+F"'Selection.MoveLeft Unit:=wdCharacter, Count:=3, Extend:=wdExtendIf Selection.Type = wdSelectionNormal Then'Selection.Font.Italic = TrueSelection.CutSelection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _PreserveFormatting:=FalseSelection.MoveRight Unit:=wdCharacter, Count:=1Selection.TypeBackspaceSelection.TypeText Text:="eq \f()"Selection.MoveLeft Unit:=wdCharacter, Count:=1Selection.Paste'Selection.TypeText Text:=")"Selection.Fields.UpdateSelection.MoveRight Unit:=wdCharacter, Count:=1ElseMsgBox "您没有选择文字。"End If'End Sub

Sub 弧()'' 弧 Macro' 设置选定的两个字母上加弧Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtendIf Selection.Type = wdSelectionNormal ThenSelection.Font.Italic = TrueSelection.CutSelection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _PreserveFormatting:=FalseSelection.Delete Unit:=wdCharacter, Count:=1Selection.TypeText Text:="eq \o(\s\up5(⌒"Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtendSelection.Font.Scaling = 150Selection.MoveRight Unit:=wdCharacter, Count:=1Selection.Font.Scaling = 100Selection.TypeText Text:="),\s\do0("Selection.PasteSelection.TypeText Text:="))"Selection.Fields.UpdateSelection.MoveRight Unit:=wdCharacter, Count:=1ElseMsgBox "您没有选择文字。"End If'End Sub

Sub Password()'' 文件自动添加密码。'If ActiveDocument.WriteReserved = False ThenIf MsgBox("是否为本文档添加密码？", vbYesNo) = vbYes Then With ActiveDocument.Password = "123456".WritePassword = "123456"End With

Else End IfElseEnd IfEnd Sub

Sub Example()'根据文档字符数中重复频率排序字符并计数'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* Created By SHOUROU@OfficeFans 2008-2-24 18:05:42'仅测试于System: Windows NT Word: 11.0 Language: 2052'№ 0334^The Code CopyIn [ThisDocument-ThisDocument]^''* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Dim myDictionary As Object, MyString As StringDim iCount As Long, i As Long, n As LongDim ochar As String, TempA As Variant, st As SingleDim Array_Keys() As Variant, Array_Items() As Variantst = VBA.TimerSet myDictionary = CreateObject("Scripting.Dictionary")MyString = ActiveDocument.Content.Textn = Len(MyString) - 1For i = 1 To nochar = VBA.Mid(MyString, i, 1)If myDictionary.Exists(ochar) = False ThenmyDictionary.Add ochar, 1ElsemyDictionary(ochar) = myDictionary(ochar) + 1End IfNextMyString = ""iCount = myDictionary.Count - 1Array_Keys = myDictionary.keysArray_Items = myDictionary.ItemsSet myDictionary = NothingFor i = 0 To iCount - 1For n = i + 1 To iCountIf Array_Items(i) < Array_Items(n) ThenTempA = Array_Items(n)Array_Items(n) = Array_Items(i)Array_Items(i) = TempATempA = Array_Keys(n)Array_Keys(n) = Array_Keys(i)Array_Keys(i) = TempAEnd IfNext nNext iFor i = 0 To iCountMyString = MyString & Array_Keys(i) & "　" & Array_Items(i) & Chr(13)NextActiveDocument.Content.Text = MyStringMsgBox "共有" & iCount & "个不重复的字符,用时" & VBA.Format(Timer - st, "0.00") & "秒"End Sub

Sub yy()'本代码旨在解决WORD中数据转化为千分位'数据限定要求:-922,337,203,685,477.5808 到 922,337,203,685,477.5807'转化结果1000以上数据以千分位计算,小数点右侧保留二位小数;1000以下数据不变Dim myRange As Range, i As Byte, myValue As CurrencyOn Error Resume NextApplication.ScreenUpdating = False '关闭屏幕更新NextFind: Set myRange = ActiveDocument.Content '定义为主文档文字部分With myRange.Find '查找.ClearFormatting '清除格式.Text = "[0-9]{4,15}" '4到15位数据.MatchWildcards = True '使用通配符Do While .Execute '每次查找成功i = 2 '起始值为2'如果是有小数点If myRange.Next(wdCharacter, 1) = "." Then'进行一个未知循环While myRange.Next(wdCharacter, i) Like "#"i = i + 1 '只要是[0-9]任意数字则累加Wend'重新定义RANGE对象myRange.SetRange myRange.Start, myRange.End + i - 1End IfmyValue = VBA.Val(myRange) '保险起见转换为数据,也可省略myRange = VBA.Format(myValue, "Standard") '转为千分位格式GoTo NextFind '转到指定行LoopEnd WithApplication.ScreenUpdating = True '恢复屏幕更新End Sub

Sub setpicsize_1() '设置图片大小为当前的百分比Dim n '图片个数Dim picwidthDim picheightIf Selection.Type = wdSelectionNormal Then On Error Resume Next '忽略错误For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片picheight = ActiveDocument.InlineShapes(n).Heightpicwidth = ActiveDocument.InlineShapes(n).WidthActiveDocument.InlineShapes(n).Height = picheight * 0.5 '设置高度ActiveDocument.InlineShapes(n).Width = picwidth * 0.5 '设置宽度Next nFor n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片picheight = ActiveDocument.Shapes(n).Heightpicwidth = ActiveDocument.Shapes(n).WidthActiveDocument.Shapes(n).Height = picheight * 0.5 '设置高度倍数ActiveDocument.Shapes(n).Width = picwidth * 0.5 '设置宽度倍数Next n

Else End IfEnd Sub

Sub setpicsize_2() '设置图片大小为固定值Dim n '图片个数On Error Resume Next '忽略错误For n = 1 To ActiveDocument.InlineShapes.Count 'InlineShapes类型图片ActiveDocument.InlineShapes(n).Height = 400 '设置图片高度为 400pxActiveDocument.InlineShapes(n).Width = 300 '设置图片宽度 300pxNext nFor n = 1 To ActiveDocument.Shapes.Count 'Shapes类型图片ActiveDocument.Shapes(n).Height = 400 '设置图片高度为 400pxActiveDocument.Shapes(n).Width = 300 '设置图片宽度 300pxNext nEnd Sub

Sub 图片版式转换()'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋'* Created By SHOUROU@ExcelHome 2007-12-11 5:28:26'仅测试于System: Windows NT Word: 11.0 Language: 2052'№ 0281^The Code CopyIn [ThisDocument-ThisDocument]^''* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－'Option Explicit Dim oShape As Variant, shapeType As WdWrapTypeOn Error Resume NextIf MsgBox("Y将图片由嵌入式转为浮动式,N将图片由浮动式转为嵌入式", 68) = 6 ThenshapeType = Val(InputBox(Prompt:="请输入图片版式:0=四周型,1=紧密型, " & vbLf & _"3=衬于文字下方,4=浮于文字上方", Default:=0))For Each oShape In ActiveDocument.InlineShapesSet oShape = oShape.ConvertToShapeWith oShapeSelect Case shapeTypeCase 0, 1.WrapFormat.Type = shapeTypeCase 3.WrapFormat.Type = 3.ZOrder 5Case 4.WrapFormat.Type = 3.ZOrder 4Case ElseExit SubEnd Select.WrapFormat.AllowOverlap = False '不允许重叠End WithNextElseFor Each oShape In ActiveDocument.ShapesoShape.ConvertToInlineShapeNextEnd IfEnd Sub

Sub GetChineseNum2()'把数字转化为汉字大写人民币Dim Numeric As Currency, IntPart As Long, DecimalPart As Byte, MyField As Field, Label As StringDim Jiao As Byte, Fen As Byte, Oddment As String, Odd As String, MyChinese As StringDim strNumber As StringConst ZWDX As String = "壹贰叁肆伍陆柒捌玖零" '定义一个中文大写汉字常量On Error Resume Next '错误忽略If Selection.Type = wdSelectionNormal Then

With SelectionstrNumber = VBA.Replace(.Text, " ", "")Numeric = VBA.Round(VBA.CCur(strNumber), 2) '四舍五入保留小数点后两位'判断是否在表格中If .Information(wdWithInTable) Then _.MoveRight Unit:=wdCell Else .MoveRight Unit:=wdCharacter'对数据进行判断,是否在指定的范围内If VBA.Abs(Numeric) > 2147483647 Then MsgBox "数值超过范围!", _vbOKOnly + vbExclamation, "Warning": Exit SubIntPart = Int(VBA.Abs(Numeric)) '定义一个正整数Odd = VBA.IIf(IntPart = 0, "", "圆") '定义一个STRING变量'插入中文大写前的标签Label = VBA.IIf(Numeric = VBA.Abs(Numeric), "人民币金额大写:　", "人民币金额大写:　负")'对小数点后面二位数进行择定DecimalPart = (VBA.Abs(Numeric) - IntPart) * 100Select Case DecimalPartCase Is = 0 '如果是0,即是选定的数据为整数Oddment = VBA.IIf(Odd = "", "", Odd & "整")Case Is < 10 ' 0 ThenFor i = 1 To .FoundFiles.CountIf InStr(fs.FoundFiles(i), "~$") = 0 ThenSet myDoc = Documents.Open(.FoundFiles(i), Visible:=False)With myDocstrpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")strpara1 = Left(strpara1, 10)strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")If Len(strpara1) < 2 Or Len(strpara2) < 2 Then GoTo hddocname = strpara1 & "_" & strpara2docname = CleanString(docname)For Each a In Array("\", "/", ":", "*", "?", """ ", "", "|")docname = Replace(docname, a, "")Next.SaveAs mypath & "另存为\" & docname & ".doc"n = n + 1.CloseEnd WithEnd IfNextEnd IfEnd WithMsgBox "共处理了" & fs.FoundFiles.Count & "个文档，保存于目标文件夹的名称为“另存为”的下一级文件夹中。" _& vbCrLf & "处理时间：" & Format(Timer - st, "0") & "秒。"Application.ScreenUpdating = TrueExit Sub

hd:MsgBox "运行出现意外，程序终止！" & vbCrLf & "已处理文档数：" & n _& vbCrLf & "出错文档：" & vbCrLf & fs.FoundFiles(i)If Not myDoc Is Nothing Then myDoc.CloseEnd Sub

这段代码是我请 @sylun 为我编写的，很好用。 这段代码可以不打开文档提取指定文件夹的WORD文档的中的第1段的前10个字符和第2段落的文字作为并被提取文档的“另存为”文件的文件名，如果想修改提取的文字内容，可修改

strpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")strpara1 = Left(strpara1, 10)strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")

这三行。前两行是提取第一段的前10字符，后一行是提取第二段的内容。如果文档标题是第一段，第二段是作者，把strpsra1＝Left(strpara1, 10)一行删除，如果没有标题，第一段是一大段内容，把strpara2一行删除。