word2007的vba代码 selection.goto 方法,在pb中如何调用

vba读取word内容会弄吗？dir(*.Doc)知道怎么用吗？大约思路吧1、枚举所有word文档2、查找word中的你需要的内容3、填写到excel表中呵呵，不知道你vba水平如何，但按你的题目，我也只能回答这么多了。

按这个思路百度去，总会找到办法的。

如何利用vba程序在word中调用excel单元格中的数据

展开全部 '代码已经测试过，请注意保持良好习惯，及时采纳，谢谢。

Sub PasteToWordDoc（)'' 需要引用MIcrosoft Word 12.0 Object Library（注：12.0是版本号，可以不同）'Application.ScreenUpdating = False '关闭屏幕刷新'Selection.CopyDim wdApp As Word.Application, wdDoc As Word.DocumentDim strDocPath As String '全路径文件名Dim blnNoWd As Boolean, blnNoWdd As BooleanOn Error Resume NextstrDocPath = ＂C:\Users\wine\Desktop\可ihikhoi年.docm＂ '如果与Excel工作薄同路径，采用这面的语句也可'strDocPath = ThisWorkbook.Path & ＂\可ihikhoi年.docm＂'调用word程序对象Set wdApp = GetObject(, ＂Word.Application＂) '实例化word对象变量If wdApp Is Nothing Then '判断word程序是否正在运行Set wdApp = CreateObject(＂Word.Application＂)wdApp.Visible = FalseblnNoWd = TrueEnd If'调用word 文档对象Set wdDoc = wdApp.Documents(strDocPath)If wdDoc Is Nothing ThenSet wdDoc = wdApp.Documents.Open(Filename:=strDocPath, Visible:=flase)blnNoWdd = TrueElsewdDoc.ActivateEnd IfwdApp.Selection.PasteExcelTable False, False, FalsewdDoc.Save'恢复环境If blnNoWdd Then wdDoc.Close: Set wdDoc = NothingIf blnNoWd Then wdApp.Quit: Set wdApp = NothingApplication.ScreenUpdating = TrueOn Error GoTo 0End Sub

请问如何在word里输入数字的时候能自动加上千分符和.00这样的两位...

其他输入法不清楚，搜狗输入法先输入v再输入数字会出现千分位形式，但.00还是要自己输入有一段宏代码运行后可以自动给数字加千分位及两位小数位转帖在Word中也实现数字自动千分位格式这个方法比较好。

收藏一下。

（转自“中国会计视野论坛”里zhufree朋友的帖子。

）打开WORD程序，在上方菜单区域中，右键单击，选中Visual Basic。

点击“Visual Basic编辑器”图标，打开Visual Basic，在“ThisDocument ”中双击，然后在右边的窗口中复制下方的代码：2、对所有的数字加千分位，并且自动加上尾数.00Sub yycealjj1()'本代码旨在解决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关闭Visual Basic编辑器，回到WORD界面。

输入文章后，点击“运行宏”图标，运行yycealjj1宏，即可对数字加千分位。

（可以插入模板，以后而要时加载即可。

）

VBA中用EXCEL打开word,Set wdoc = wdapp.documents.Open(＂D:\...

在office PPT中，插入向右指的手型图标的方法： 1、单击插入----&gt；符号----&gt；其它符号，如图所示；2、弹出符号对话框，插入如图所示的符号即可。

WordVBA复制某一行,将这一行的内容作为文件名保存

展开全部试试下面的代码，在网上找的：Sub Word文件改名（） Application.ScreenUpdating = False Down = MsgBox（＂请保证每个Word文档的第三行没有空行＂ & vbCrLf & ＂否则无法重命名，运行宏会出错＂ & vbCrLf & vbCrLf & ＂也不能出现第三行相同相等字段内容＂ & vbCrLf & ＂否则只能重命名到第一个打开的同名文档＂， vbQuestion + vbYesNo， ＂★☆ 重命名时请注意 （1） ☆★＂）If Down = vbNo Then Exit Sub End If '选择“是”，执行下列操作 Dim MyPath As String, i As Integer, myDoc As Document With Application.FileDialog(msoFileDialogFolderPicker) .Title = ＂选择要处理目标文件夹＂ & ＂——（给文档进行重命名）＂ If .Show = -1 Then MyPath = .SelectedItems(1) Else Exit Sub End If End With With Application.FileSearch .LookIn = MyPath .FileType = msoFileTypeWordDocuments If .Execute > 0 Then For i = 1 To .FoundFiles.Count Set myDoc = Documents.Open(FileName:=.FoundFiles(i)) ' B可以替换的宏' 以下是处理格式所录制的宏，可根据所需录制Dim myS, myP As String myP = ActiveDocument.Path Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=3 '修改数值可以以不同的行号命名 Selection.EndKey wdLine Selection.HomeKey wdLine, wdExtend myS = Selection.Range.Text ActiveDocument.SaveAs FileName:=myP & ＂\＂ & myS & ＂.doc＂' 以上可以换成是你自己录制的宏' C公共部分的代码Application.DisplayAlerts = False '强制执行“是”'ActiveDocument.Saved = True'强制执行“否”ActiveDocument.Close '退出 Next End If End With Application.ScreenUpdating = True MsgBox ＂所选文件夹内的Word已经重命名完毕！！！＂ & vbCrLf & ＂＂ & vbCrLf & ＂但不能对第二个同名文件进行重命名＂ & vbCrLf & ＂＂ & vbCrLf & ＂修改日期为当前时间的即是重命名后的文档＂， 64， ＂☆★批量处理完毕★☆＂ThisDocument.Application.QuitEnd Sub

如何把一个排版类似、较长的word文件,分页批量保存

通常的办法就是把Word每两页拷贝，再新建空白Word文档，粘贴。

如果文档页数不算多，也可采用，但是在页数很大的情况下，就不宜采用手工操作。

另外可用VBA来实现批量自动处理。

在文档的ThisDocument的代码页中输入以下代码，然后执行Sub SaveParagraph（) 即可：Option ExplicitSub SaveParagraph()Dim i As Integer, PageNo As IntegerDim aDoc As DocumentDim myDoc As DocumentDim sPage As StringSet myDoc = ThisDocument'文档视图设定为页面方式ActiveWindow.View.Type = wdPageViewmyDoc.Repaginate'获得文档页数并赋值给变量 PageNoPageNo = myDoc.BuiltInDocumentProperties(wdPropertyPages)For i = 1 To PageNomyDoc.Activate' 光标移动到文档某一页的开始Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=i' 全选文档某一页的所有内容Selection.EndKey Unit:=wdStory, Extend:=wdExtendsPage = Selection.Text'保存到一个文件中Set aDoc = Documents.AddaDoc.Content.Text = sPageaDoc.SaveAs FileName:=＂c:\＂ & CInt(i) & ＂.doc＂aDoc.CloseNextEnd Sub楼主可试试这个VBA.

VBA循环中如何能使ON ERROR语句多次有效

展开全部 问题是，你的Line后面根本没有处理错误。

帮助文档里是这样解释的：“一个“允许的”错误处理程序是由 On Error 语句打开的一个处理程序；一个“活动的”错误处理程序是处理错误的过程中允许的错误处理程序。

如果在错误处理程序处于活动状态时（在发生错误和执行 Resume、Exit Sub、Exit Function 或 Exit Property 语句之间这段时间）又发生错误，则当前过程的错误处理程序将无法处理这个错误。

”加一句：Resume NextSub test1()Dim iDo While i 4For i = 1 To 3On Error GoTo LineChDir ＂D:\TMP＂Line:Resume NextNext iOn Error GoTo Line:LoopEnd Sub或者，干脆用On Error Resume Next 吧Sub test2()Dim iOn Error Resume Next Do While i 4For i = 1 To 3ChDir ＂D:\TMP＂Next iLoopEnd Sub你也可以仔细研究一下帮助文档里的例子On Error 语句示例本示例先使用 On Error GoTo 语句在一个过程中指定错误处理的代码所在。

本示例中，试图删除一已经打开的文件从而生成的错误码为 55。

这个错误将由示例中的错误处理程序码来处理，处理完后，控制会回到发生错误的语句处。

On Error GoTo 0 语句关闭错误陷阱。

然后 On Error Resume Next 语句用来改变错误陷阱，以便发觉下一个语句产生的错误的范围。

请注意示例中使用 Err.Clear 在错误处理完后，清除 Err 对象的属性。

Sub OnErrorStatementDemo() On Error GoTo ErrorHandler ' 打开错误处理程序。

Open ＂TESTFILE＂ For Output As #1 ' 打开输出文件。

Kill ＂TESTFILE＂ ' 试图删除已打开的文件。

On Error Goto 0 ' 关闭错误陷阱。

On Error Resume Next ' 改变错误陷阱。

ObjectRef = GetObject(＂MyWord.Basic＂) ' 试图启动不存在 ' 的对象'检查可能发生的 Automation 错误。

If Err.Number = 440 Or Err.Number = 432 Then ' 告诉用户出了什么事。

然后清除 Err 对象。

Msg = ＂There was an error attempting to open the Automation object!＂ MsgBox Msg, , ＂Deferred Error Test＂ Err.Clear ' 清除 Err 对象字段。

End If Exit Sub ' 退出程序，以避免进入错误处理程序。

ErrorHandler： ' 错误处理程序。

Select Case Err.Number ' 检查错误代号。

Case 55 ' 发生“文件已打开”的错误。

Close #1 ' 关闭已打开的文件。

Case Else ' 处理其他错误状态 . . . End Select Resume ' 将控制返回到产生错误的语句。

End Sub

请教提取word数据到excel的vba改进方法

展开全部 给出一段代码供参考。

Public myPath As StringPublic wj***Public zL As StringSub 提取简历（）Dim Js As Integer, MyName As StringDim Gs As LongzL = Cells(3, 4).Text'选择文件夹ChDrive ThisWorkbook.PathCall SelectFolder(myPath)Dim fs, f, f1, fc, s'文件名字典初始化Set wj*** = CreateObject(＂scripting.dictionary＂)Set fs = CreateObject(＂Scripting.FileSystemObject＂)Set f = fs.GetFolder(myPath) '在括号内输入你指定的目录Set fc = f.FilesGs = 0For Each f1 In fcMyName = f1.NameIf InStr(MyName, ＂doc＂) > 0 And Left(MyName, 1) ＂~＂ ThenGs = Gs + 1wj***.Add MyName, GsEnd IfNext f1Call tqjl(zL)End SubSub SelectFolder(ByRef myPath)'选择单一文件夹'www.okexcel.com.cn'Set fd = Application.FileDialog(msoFileDialogOpen)Set fd = Application.FileDialog(msoFileDialogFolderPicker)fd.InitialFileName = ThisWorkbook.Path'With Application.FileDialog(msoFileDialogFolderPicker)With fdIf .Show = -1 Then'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。

'MsgBox ＂您选择的文件夹是：＂ & .SelectedItems(1), vbOKOnly + vbInformation， ＂智能Excel＂myPath = .SelectedItems(1)End IfEnd WithEnd SubSub tqjl(zL)'On Error GoTo jiesuDim jgarr, jgJs As LongDim lsArr(1 To 100) As String, lsJs As IntegerDim WdocDim MyDocumentjgJs = wj***.Countarr = wj***.keysReDim jgarr(1 To jgJs, 1 To 32) 'Set Wdoc = CreateObject(＂word.application＂)Wdoc.Visible = FalseWith WdocFor i = 1 To jgJsMyName = arr(i - 1)导出路径文件名 = myPath & ＂\＂ & MyNameSet MyDocument = .Documents.Open（导出路径文件名）.Visible = TrueSelect Case zLCase ＂2招聘狗word简历＂Call tqsj2(MyDocument, i, jgarr)Case ＂4猎聘word简历＂Set mytable = MyDocument.Tables(3)lsJs = 0For Each mycell In mytable.Range.CellslsJs = lsJs + 1lsArr(lsJs) = qczf(mycell.Range.Text)Next mycell'jgArr(i, 1) = zL '简历名称jgarr(i, 1) = lsArr(2) '姓名jgarr(i, 2) = lsArr(2) '姓名jgarr(i, 3) = lsArr(4) '性别jgarr(i, 4) = lsArr(9) '出生年月jgarr(i, 7) = lsArr(17) '婚姻状况jgarr(i, 8) = lsArr(15) '工作经验jgarr(i, 9) = lsArr(13) '学历End Select.ActiveDocument.CloseNext iEnd Withjiesu:Wdoc.Quit'写入结果Sheets（＂提取结果＂）.Range(＂B2:az100000＂).ClearContentsSheets（＂提取结果＂）.Cells(2, 2).Resize(jgJs, 32) = jgarrEnd SubSub tqsj2(MyDocument, i, ByRef jgarr)'tqsj2(MyDocumet, i, jgArr)Dim lsArr(1 To 100) As StringDim lsJs As Integer, ls_Text As String, ls_sZ As IntegerDim lsZD '临时字典 key-单元格的值 item-序号Dim bXh As IntegerConst fgf = ＂ ＂Set lsZD = CreateObject(＂scripting.dictionary＂)Set mytable = MyDocument.Tables(1)lsJs = 0For Each mycell In mytable.Range.CellslsJs = lsJs + 1lsArr(lsJs) = mycell.Range.TextNext mycellxm = Mid(lsArr(4), 1, InStr(lsArr(4), Space(1)) - 1)jgarr(i, 1) = xm '姓名jgarr(i, 2) = xmarr = Split(lsArr(6), ＂|＂)jgarr(i, 3) = Trim(arr(0))jgarr(i, 4) = Mid(Trim(arr(3)), 1, InStr(Trim(arr(3)）， ＂年＂）） '出生年月jgarr(i, 7) = Trim(arr(1)） '婚姻状况jgarr(i, 8) = lsArr(7) '工作经验jgarr(i, 9) = Trim(arr(4)） '学历'求职方向Set mytable = MyDocument.Tables(3)lsJs = 0: lsZD.RemoveAllFor Each mycell In mytable.Range.CellslsJs = lsJs + 1lsArr(lsJs) = qczf2(mycell.Range.Text)If Not lsZD.exists(lsArr(lsJs)) ThenlsZD.Add lsArr(lsJs), lsJsEnd IfNext mycellIf lsZD.exists（＂期望地点＂） Thenjgarr(i, 12) = lsArr(lsZD（＂期望地点＂） + 1)End If'期望职位分解If lsZD.exists（＂期望职位＂） Thenls_Text = lsArr(lsZD（＂期望职位＂） + 1)jgarr(i, 12) = wbfj(ls_Text)End If'职位性质If lsZD.exists（＂工作性质＂） Thenjgarr(i, 10) = lsArr(lsZD（＂工作性质＂） + 1)End IfIf lsZD.exists（＂期望行业＂） Thenjgarr(i, 11) = lsArr(lsZD（＂期望行业＂） + 1)End IfIf lsZD.exists（＂期望薪资＂） Thenls_Text = lsArr(lsZD（＂期望薪资＂） + 1)If ls_Text ＂面议＂ Thenls_sZ = Mid(ls_Text, 1, InStr(ls_Text, ＂-＂) - 1)jgarr(i, 13) = xzfw(ls_sZ)Elsejgarr(i, 13) = ＂面议＂End IfEnd If'教育经历Set mytable = MyDocument.Tables(5)lsJs = 0For Each mycell In mytable.Range.CellslsJs = lsJs + 1lsArr(lsJs) = mycell.Range.TextNext mycellls_Text = lsArr(1)arr = Split(ls_Text, fgf) '中文空格分割jgarr(i, 14) = arr(0) & ＂|＂ & qczf(arr(1)) & ＂|＂ & qczf(arr(2)) & ＂|＂ & qczf(arr(3)）'工作经历'bXh = 7'ls_Text = qczf2(MyDocumet.Tables(bXh).Range.Cells(1).Text)Set mytable = MyDocume...

转载请注明出处51数据库 » vba word gotonext