excel vba 读取 word 指定字符
Sub 按钮1()Dim myPath As StringSet Wdapp = CreateObject("Word.Application")Wdapp.Visible = TrueApplication.ScreenUpdating = False '关闭屏幕刷新' On Error Resume Next '捕捉错误myPath = ThisWorkbook.Path & "\多房地产预评估函.doc" '定义word文件路径,自己修改Set wdDoc = Wdapp.Documents.Open(myPath) '打开wordwdDoc.Activatesr = wdDoc.Content '将word的文档内容赋予变量srMsgBox Mid(sr, InStr(sr, "籍贯") + 3, 2)wdDoc.Close '关闭wordWdapp.QuitSet Wdapp = NothingSet wdDoc = NothingApplication.ScreenUpdating = True '开启屏幕刷新End Sub
VBA excel调用word内容
在有word文件的文件夹中新建一个excel工作簿,打开工作簿,按Alt+F11,把下面的代码复制进去,按F5执行。
代码会复制work文件的前300个字符到excel中。
Sub test() Dim i%, myName$, myPath$, AppWord As Object Set AppWord = CreateObject("Word.Application") myPath = ThisWorkbook.Path & "\" myName = Dir(myPath & "*.doc*") With ActiveSheet .Columns("A:B").ClearContents Do While myName "" AppWord.Documents.Open Filename:=myPath & myName i = i + 1 .Cells(i, 1) = myName .Cells(i, 2) = AppWord.ActiveDocument.Range(Start:=0, End:=300).Text AppWord.ActiveDocument.Close False myName = Dir Loop End With AppWord.Quit Set AppWord = Nothing MsgBox "已完成。
"End Sub...
如何用VBA拷贝我的word文档内容至EXCEL单元格
Sub abc()Dim App, WrdDoc, MyPath, MyFile, BM, StrMypath = "文件实际路径\*.doc" '请修改实际储存路径!Set App = CreateObject("Word.Application") '用Set关键字创建Word应用成序对象!MyFile = Dir(Mypath) ' 获得第一个WORD文档do while MyFile "" ' 遍历Mypath下面的所有WORD文档App.Visible = TrueSet WrdDoc = App.Documents.Open(MyFile) '打开这个Word文件!for each BM in WrdDoc.Bookmarks ' 遍历文档中的所有书签Str = BM.Range ' 读取书签内容next BMWrdDoc.Close ' 关闭文件MyFile = Dir ' 下一个WORD文档LoopSet App = NothingEnd Sub
怎么vba实现word表格批量转为excel
注:vba偶并不太熟(偶一般是用c#和delphi的),VBA只是稍有了解,以下代码大部分是偶google到的内容拼出来的。
。
。
。
。
如下,使用时先更改test下的docpath和xlspath路径设定,docpath即你的word的目录,此目录包括子目录下的所有doc将被读取,xlspath即输出目录,需要存在 在VBA窗口中,先在视图下显示立即窗口以观察进度,程序最后的输出类似这样 正在读取[1]:->D:\1\Resume.doc 正在生成:->d:\2\Resume 正在读取[2]:->D:\1\简历(简).doc 正在生成:->d:\2\简历(简) 正在读取[3]:->D:\1\计数器说明.doc 正在生成:->d:\2\计数器说明 共耗时0分41秒 Option Explicit Dim docpath As String, xlspath As String'ResultFlag=0 获取路径'ResultFlag=1 获取文件名'ResultFlag=2 获取扩展名 Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String Dim SplitPos As Integer, DotPos As Integer SplitPos = InStrRev(FullPath, "\") DotPos = InStrRev(FullPath, ".") Select Case ResultFlag Case 0 SplitPath = Left(FullPath, SplitPos - 1) Case 1 If DotPos = 0 Then DotPos = Len(FullPath) + 1 SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1) Case 2 If DotPos = 0 Then DotPos = Len(FullPath) SplitPath = Mid(FullPath, DotPos + 1) Case Else Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!" End Select End Function Public Function FileFolderExists(ByVal strFullPath As String) As Boolean On Error GoTo EarlyExit If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True EarlyExit: On Error GoTo 0 End Function Sub Test() '使用双字典,旨在提高速度 Dim MyName, Dic, Did, I, T, F, TT, MyFileName, Doc, Ke Dim count As Integer count = 0 T = Time docpath = "D:\1\" xlspath = "d:\2\" Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象 Set Did = CreateObject("Scripting.Dictionary") Dic.Add (docpath), "" I = 0 Do While I Ke = Dic.keys '开始遍历字典 MyName = Dir(Ke(I), vbDirectory) '查找目录 Do While MyName "" If MyName "." And MyName ".." Then If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录 Dic.Add (Ke(I) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目 End If End If MyName = Dir '继续遍历寻找 Loop I = I + 1 Loop 'Did.Add ("文件清单"), "" '以查找D盘下所有EXCEL文件为例 For Each Ke In Dic.keys MyFileName = Dir(Ke & "*.doc") Do While MyFileName "" Doc = Ke & MyFileName Did.Add (Doc), "" count = count + 1 Debug.Print "正在读取[" & count & "]:->" & Doc doc2xls (Doc) MyFileName = Dir Loop Next ' For Each Sh In ThisWorkbook.Worksheets ' If Sh.Name = "XLS文件清单" Then ' Sheets("XLS文件清单").Cells.Delete ' F = True ' Exit For ' Else ' F = False ' End If ' Next 'If Not F Then ' Sheets.Add.Name = "XLS文件清单" 'End If 'Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys) TT = Time - T Debug.Print "共耗时" & Minute(TT) & "分" & Second(TT) & "秒" End Sub Sub doc2xls(filename As String) Dim xlApp As Object, xlSheet As Object, outfile As String, c As Object Set xlApp = CreateObject("Excel.Application") Set xlSheet = xlApp.Workbooks.Add.Sheets(1) Dim Wapp As Object, Doc As Object, GetDocText As Object 'Word Application 对象、Document 对象 Set Wapp = CreateObject("Word.Application") '创建Word Application 对象 Set Doc = Wapp.Documents.Open(filename, ReadOnly:=True) '打开文档,返回一个文档对象'xlSheet.Range("A1") = Doc.Content.Text Doc.Application.Selection.WholeStory ''''全选 Doc.Application.Selection.Copy ''''''''''复制 xlSheet.Range("A1").Select xlSheet.Paste outfile = xlspath + Replace(SplitPath(filename, 1), ".doc", ".xls") Debug.Print "正在生成:->" & outfile xlSheet.Parent.SaveAs outfile xlApp.Quit Set xlSheet = Nothing Set xlApp = Nothing Wapp.Quit Set Doc = Nothing Set Wapp = Nothing End Sub
WORD、高手们、宏、VBA、宏有关批量运行
Sub 批量操作WORD() Dim path As String Dim FileName As String Dim worddoc As Document Dim MyDir As String MyDir = "G:\360data\重要数据\桌面\新建文件夹 (2)" '文件夹路径根据需要自己修改,需要处理的文件都放该文件夹内 FileName = Dir(MyDir & "\*.doc*", vbNormal) Do Until FileName = "" If FileName ThisDocument.Name Then Set worddoc = Documents.Open(MyDir & "\" & FileName) worddoc.Activate Call 处理WORD '调用宏,换成你自己宏的名字 worddoc.Close True FileName = Dir() End If LoopSet worddoc = NothingEnd Sub'======================下面的宏换成你自己的宏=================================Sub 处理WORD() ActiveDocument.Paragraphs(1).Range.Select Selection.Font.Size = 72End Sub
WORD VBA问题
1. 库的配置在默认情况下,新创建的excel vba中不支持定义word对象。
所以需要先引入word库,操作步骤如下:1.1 打开excel vba 界面1.2 选中其中的一个Module1.3 选择菜单, Tools --> References在打开的对话框中选择类似 "Microsoft Word 14.0 Object Library".1.4 点击OK保存配置。
2. 打开文档Set wordApplication = CreateObject("Word.Application")wordApplication.Visible = FalseDim hasOpenDoc As BooleanhasOpenDoc = IsOpen(filePath) ' is a self-defined function to check file is opendIf hasOpenDoc = True thenSet wordDoc = GetObject(filePath)End ifIf hasOpenDoc = False ThenSet wordDoc = wordApplication.Documents.Open(filePath)End ifwordDoc.ActiveWith wordApplicationDim aParagraph As Word.ParagraphFor Each aParagraph In wordDoc.Paragraphs' do some thing to every paragraph.Next aParagraphEnd withwordDoc.CloseSet wordDoc = nothing ' 如下这段代码引用某位牛人的,非常感谢他。
由于路径丢失,不能给出链接, 抱歉' 如下的找寻方式,能够正确的找出文件是否被打开Function IsOpen(fileName As String) As BooleanIsOpen = FalseDim findFile As IntegerfindFile = FreeFile()On Error GoTo ErrOpenOpen fileName For Binary Lock Read Write As findFileClose findFileExit FunctionErrOpen:If Err.Number 70 ThenMsg = "Error # " & Str(Err.Number) & "was generated by " & Err.Source & Chr(13) & Err.DescriptionMsgBox Msg, "Error", Err.HelpFile, Err.HelpContext ElseIsOpen = TrueEnd IfEnd Function
用vba打开word模板并修改后保存
1、打开Word文件的 VBA编辑器,快捷键 Alt+F11,右击【ThisDocument】-》 【插入模块】;用VBA代码设置Word自动保存的步骤2、双击刚才插入的【模块1】,添加如下代码:Sub 自动备份()Dim NewTimeNewTime = Now + TimeValue(“00:05:10”)Dim myPath$, myName$myPath = ActiveDocument.PathmyName = Left$(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)ChangeFileOpenDirectory myPathActiveDocument.SaveAs FileName:=myName & “_temp.doc”, ReadOnlyRecommended:=TrueActiveDocument.SaveAs FileName:=myName & “.doc”, ReadOnlyRecommended:=FalseApplication.OnTime NewTime, “自动备份”CreateObject(“Wscript.shell”).popup “备份成功,备份文件名为:” & myName & “_temp.doc”, 2, “提示!2秒后自动关闭!”End Sub用VBA代码设置Word自动保存的步骤用VBA代码设置Word自动保存的步骤3、双击【ThisDocument】并在其中 添加如下代码:Private Sub Document_Open()Call 自动备份End Sub用VBA代码设置Word自动保存的步骤4、默认自动备份时间为5min,如要调整请修改【模块1】中一句代码:如图中红框所示:时间格式为:HH : mm : ss用VBA代码设置Word自动保存的步骤5、保存代码及文件,且关闭word并重新打开,重新打开点击【选项】-》 【启用此内容】,如图:用VBA代码设置Word自动保存的步骤6、默认备份文件名为:【原文件名_temp,Lee.doc】且为只读,提示对话框2s后自动关闭。
备份效果显示如下:
如何用VBA提取word中的指定文本到excel
Sub abc()Dim App, WrdDoc, MyPath, MyFile, BM, StrMypath = "文件实际路径\*.doc" '请修改实际储存路径!Set App = CreateObject("Word.Application") '用Set关键字创建Word应用成序对象!MyFile = Dir(Mypath) ' 获得第一个WORD文档do while MyFile "" ' 遍历Mypath下面的所有WORD文档 App.Visible = True Set WrdDoc = App.Documents.Open(MyFile) '打开这个Word文件! for each BM in WrdDoc.Bookmarks ' 遍历文档中的所有书签 Str = BM.Range ' 读取书签内容 next BM WrdDoc.Close ' 关闭文件 MyFile = Dir ' 下一个WORD文档LoopSet App = NothingEnd Sub...
转载请注明出处51数据库 » word vba mkdir path