利用excelVBA批量修改文件名以及自动插图到word
Word中自动批量插入图片的VBA代码
Word中自动批量插入图片的VBA代码为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要24小时以上,中间还会出现DOC文件澎湃死机,想起来头就大.根据工作的流程,定了个索引文件格式,写了个VBA脚本,实现了(1)在WORD中插入表格(关键是单元格合并);(2)在WORD中插入文本框(浮于表格与图片上);(3)定义索引文件的格式(编号\图片\说明);(4)在WORD中读取索引文件格式.结果,完成一个图册文件的制作,只用了不到20分钟,真是轻松.在工作有好的帮手真的非常重要,thank QCJ.下面是它的VBA代码,等到有时间时,用VC把它实现打包,让更多的人更简单地用吧.==================================Sub test()'' test Macro' 宏在 2007-7-16 由 FtpDown 录制'插入表格Dim filename As String, str1() As String, tmp As String, i As IntegerDim photoimg As String, gisimg As Stringfilename = "c:\set.txt" '这里是文本文件所在路径位置Open filename For Input As 1Do Until EOF(1)Line Input #1, tmpstr1 = Split(tmp, ",")photoimg = str1(2) & "\1.jpg"gisimg = str1(2) & "\2.jpg"Selection.Collapse Direction:=wdCollapseStartSet myTable = ActiveDocument.T ables.Add(Range:=Selection.Range, _ NumRows:=2, NumColumns:=3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _wdAutoFitFixed)'修改表格的高宽myTable.Rows(1).HeightRule = wdRowHeightAtLeastmyTable.Rows(1).Height = CentimetersToPoints(8.62)myTable.Columns(1).PreferredWidthType = wdPreferredWidthPointsmyTable.Columns(1).PreferredWidth = CentimetersToPoints(12)myTable.Columns(2).PreferredWidthType = wdPreferredWidthPointsmyTable.Columns(2).PreferredWidth = CentimetersToPoints(0.42)myTable.Columns(3).PreferredWidthType = wdPreferredWidthPointsmyTable.Columns(3).PreferredWidth = CentimetersToPoints(12.32)myTable.Rows(2).HeightRule = wdRowHeightAtLeastmyTable.Rows(2).Height = CentimetersToPoints(8.62)'合并表格myTable.Cell(Row:=1, Column:=2).Merge _MergeTo:=myTable.Cell(Row:=2, Column:=2)myTable.Cell(Row:=1, Column:=3).Merge _MergeTo:=myTable.Cell(Row:=2, Column:=3)'插入图片myTable.Cell(Row:=1,Column:=1).Range.InlineShapes.AddPicture filename:= _ photoimg, LinkToFile:=False, _SaveWithDocument:=TruemyTable.Cell(Row:=1,Column:=1).Range.InlineShapes(1).Height = 244.35 myTable.Cell(Row:=1,Column:=1).Range.InlineShapes(1).Width = 344.25myTable.Cell(Row:=2,Column:=1).Range.InlineShapes.AddPicture filename:= _ photoimg, LinkToFile:=False, _SaveWithDocument:=TruemyTable.Cell(Row:=2,Column:=1).Range.InlineShapes(1).Height = 244.35 myTable.Cell(Row:=2,Column:=1).Range.InlineShapes(1).Width = 344.25myTable.Cell(Row:=1,Column:=3).Range.InlineShapes.AddPicture filename:= _ gisimg, LinkT oFile:=False, _SaveWithDocument:=TruemyTable.Cell(Row:=1,Column:=3).Range.InlineShapes(1).Height = 498.7myTable.Cell(Row:=1,Column:=3).Range.InlineShapes(1).Width = 344.25'插入文本框Set myTB1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizo ntal, 71, 35, 172, 36)myTB1.TextFrame.T extRange = str1(1) & Chr(13) & "部件编码:" & str1(0)Set myTB2 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizo ntal, 609, 509, 165, 22)myTB2.TextFrame.T extRange = "XXXXXXXXX 2007年7月"'Set arrPic = ActiveDocument.Shapes.AddPicture("D:\我的文档\My Pictures\88888\arrow.gif", False, True, 50, 300)Selection.MoveDown Unit:=wdLine, Count:=2Selection.TypeParagraphLoopCloseEnd SubSub sx()'' sx Macro' 宏在 2007-7-18 由 zwx 创建'Dim tmp As String, FileNumber As IntegerSet fs = CreateObject("Scripting.FileSystemObject")Set a = fs.CreateTextFile("c:\Errmeilan.txt", True)Set b = fs.CreateTextFile("c:\OKmeilan.txt", True)filename = "c:\meilan.txt" '这里是文本文件所在路径位置FileNumber = FreeFileOpen filename For Input As FileNumberDo Until EOF(FileNumber)Line Input #FileNumber, tmpstr1 = Split(tmp, ",")photoimg = str1(2) & "\001.jpg"gisimg = str1(2) & "\002.jpg"If fs.FileExists(photoimg) = True And fs.FileExists(gisimg) = True Thenb.writeLine (tmp)Elsea.writeLine (tmp)End IfLoopa.Closeb.CloseSet fs = NothingSet a = NothingSet b = NothingEnd Sub。
(完整版)用VBA实现批量修改多个Word文档内容
(完整版)用V B A实现批量修改多个W o r d文档内容-CAL-FENGHAI-(2020YEAR-YICAI)_JINGBIAN用vba实现多个word文档里的多个内容进行批量更改说明：本方法思路是借用excel的表格对多个内容进行界面管理，再用excel的vba调用word文件进行查找更改。
使用方法：将以下内容（不包括本句）复制进excel的宏模块，保存，然后excel界面设置如下：输入数据，运行宏就可以了。
（若需要现成的excel文件，请单独下载）注：版权所有严禁转载Sub 更新录入()Dim a, b, zhszhs = Sheet1.Range("c" & Rows.Count).End(xlUp).Rowp = ThisWorkbook.Path & "\"If Sheet1.Range("c5").Value = "" Thenwjj = "新文书"Elsewjj = Sheet1.Range("c5").ValueEnd IfIf zhs < 3 ThenCreateObject("Wscript.shell").popup "没有数据可以录入,请输入数据后再点击生成新文档！", 1, "提示！", 0 + 32Exit SubEnd IfIf Sheet1.Range("F1") <> "修改本级文档" ThenOn Error Resume NextSet ofso = CreateObject("Scripting.FileSystemObject") '生成文件夹ofso.CreateFolder (p & wjj)On Error GoTo 0 '替换本级或生成新的ElseIf MsgBox("是否替换本级文件夹内文档", vbYesNo, "提示") = vbNo Then: Exit SubElsewjj = ""End IfApplication.ScreenUpdating = FalseWith CreateObject("Word.Application").Visible = Falsef = Dir(p & "*.doc")Do While f <> ""i = i + 1.Documents.Open p & fFor b = 3 To zhsIf Sheet1.Range("C" & b) <> "" Then '有数据才替换.Selection.HomeKey Unit:=6 ' 到文档开始地方Do While .Selection.Find.Execute(Sheet1.Range("B" & b)) '查找s.Selection.Font.Color = wdColorAutomatic '字体颜色.Selection.Text = Sheet1.Range("C" & b) '替换.Selection.MoveRight Unit:=1, Count:=1 '右移LoopEnd IfNext.ActiveDocument.SaveAs p & wjj & "\" & f '另存为。
ExcelVBA批量修改文件夹下的文件名
ExcelVBA批量修改文件夹下的文件名今天，有同事提出想批量修改文件名，规则比较简单，在第五位后加“-”即可，代码如下：Private Sub CommandButton1_Click()Dim varFileList As VariantMsgBox "选择要重命名文件所在的文件夹,点击确定！"With Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False.ShowIf .SelectedItems.Count = 0 Then Exit Sub '未选择文件夹renamepath = .SelectedItems(1)If Right(renamepath, 1) <> "\" Thenrenamepath = renamepath + "\"End IfEnd With'获取文件夹中的所有文件列表varFileList = fcnGetFileList(renamepath)If Not IsArray(varFileList) ThenMsgBox "未找到文件", vbInformationExit SubEnd IfFor l = 0 To UBound(varFileList)Dim fsSet fs = CreateObject("Scripting.FileSystemObject")oName = renamepath & CStr(varFileList(l))If fs.FileExists(oName) And Len(CStr(varFileList(l))) > 5 Then nName = renamepath & Left(CStr(varFileList(l)), 5) & "-" & Mid(CStr(varFileList(l)), 6)Name oName As nNameEnd IfNext lMsgBox "全部修改成功！哈哈", vbInformationEnd SubPrivate Function fcnGetFileList(ByVal strPath As String, Optional strFilter As String) As Variant' 将文件列表放到数组Dim f As StringDim i As IntegerDim FileList() As StringIf strFilter = "" Then strFilter = "*.*"Select Case Right(strPath, 1)Case "\", "/"strPath = Left(strPath, Len(strPath) - 1)End SelectReDim Preserve FileList(0)f = Dir(strPath & "\" & strFilter)Do While Len(f) > 0ReDim Preserve FileList(i) As StringFileList(i) = fi = i + 1f = Dir()LoopIf FileList(0) <> Empty ThenfcnGetFileList = FileListElse fcnGetFileList = False End IfEnd Function。
VBA如何实现文件的批量重命名
VBA如何实现文件的批量重命名文件的批量重命名在日常工作和生活中非常常见，通过批量重命名可以提高工作效率并且减少手动操作带来的错误。
在VBA中，我们可以通过编写代码来实现文件的批量重命名，本文将介绍如何使用VBA 实现文件的批量重命名的具体步骤和方法。
1. 打开Excel并创建一个新的工作簿在Excel中，我们首先需要打开一个新的工作簿来进行操作。
可以通过快捷键Ctrl + N来创建一个新的工作簿。
2. 启用开发人员选项卡在Excel中，开发人员选项卡默认是隐藏的，我们需要将其显示出来。
首先点击Excel的 "文件" 菜单，在菜单中选择 "选项"，再在选项窗口中选择 "自定义功能区"，勾选 "开发人员"，点击 "确定"。
3. 进入Visual Basic Editor点击开发人员选项卡中的 "Visual Basic" 按钮，进入Visual Basic Editor界面，在左侧的工程资源管理器中，双击 "Sheet1"（可能叫其它名字）以打开代码编辑器。
4. 编写VBA代码在打开的代码编辑器中，输入以下VBA代码：```Option ExplicitSub RenameFiles()Dim FolderPath As StringDim FileName As StringDim NewName As StringDim Directory As ObjectDim File As Object' 选择文件夹路径With Application.FileDialog(msoFileDialogFolderPicker) .Title = "选择文件夹".ShowIf .SelectedItems.Count <> 0 ThenFolderPath = .SelectedItems(1)End IfEnd WithIf FolderPath = "" ThenExit SubEnd IfSet Directory =CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)' 循环处理文件For Each File In Directory.FilesFileName = NewName = "New_" & FileName ' 在文件名前添加 "New_"' 重命名文件Name File.Path As Directory & "\" & NewNameNext FileEnd Sub```5. 运行VBA代码点击代码编辑器中的运行按钮（绿色的三角形），或者按下F5键来执行VBA代码。
vba取单元格并批量修改工作表名称的方法
vba取单元格并批量修改工作表名称的方法文章标题：探秘VBA取单元格并批量修改工作表名称的方法在日常工作中，我们经常会遇到需要批量修改Excel工作表名称的情况，而VBA宏是一个非常强大的工具，可以帮助我们轻松实现这一功能。
本文将从VBA取单元格并批量修改工作表名称的方法展开讨论，以便读者能深入了解这一主题。
一、VBA取单元格方法在使用VBA宏时，我们经常需要获取单元格的数值或文本内容进行操作。
VBA提供了多种方法来获取单元格的数值或文本内容，其中最常用的方法包括使用Range对象和Cells对象来读取单元格的值。
通过这些方法，我们可以轻松获取单元格的内容，并将其应用于批量修改工作表名称的操作中。
二、批量修改工作表名称在Excel中，手动修改工作表名称是一件费时费力的工作，特别是当需要修改多个工作表名称时。
而借助VBA宏，我们可以轻松实现批量修改工作表名称的操作。
通过编写循环和使用变量来获取单元格的值，我们可以快速、准确地将单元格的内容应用于工作表名称的修改上。
三、VBA实现方法共享以下是一个简单的VBA宏代码示例，演示如何使用VBA取单元格并批量修改工作表名称的方法：```vbaSub RenameWorksheets()Dim ws As WorksheetDim i As IntegerDim newName As Stringi = 1For Each ws In ThisWorkbook.WorksheetsnewName = Sheets("Sheet1").Cells(i, 1).Value = newNamei = i + 1Next wsEnd Sub```在这个示例中，我们首先定义了一个变量ws作为工作表对象，以及变量i和newName用于循环和保存新的工作表名称。
然后我们使用For Each循环遍历所有工作表，并通过Cells对象获取指定单元格的值，然后将其应用于工作表名称的修改上。
VBA与文件批量重命名的技巧与方法
VBA与文件批量重命名的技巧与方法随着计算机数据的日益增长，对于文件的管理变得越来越重要。
有时候我们需要对大量的文件进行重命名，手动一个一个修改文件名显然不切实际。
这时候，使用VBA（Visual Basic for Applications）编程语言可以帮助我们快速、批量地处理文件重命名的工作。
本文将介绍一些常用的VBA技巧和方法，帮助您进行文件批量重命名。
1. 宏的录制与运行VBA是Microsoft Office套件的一部分，我们可以使用VBA在Office程序中编写和运行宏。
在Excel中，我们可以通过“开发人员”选项卡中的“录制宏”功能来录制我们的操作步骤。
一旦录制完成，我们可以运行宏来重复这些步骤。
对于文件批量重命名，我们可以先手动修改一个文件的名字，然后录制宏来自动化这个过程。
2. 使用FileSystemObject对象FileSystemObject对象是VBA提供的一个强大工具，它允许我们在VBA中操作文件和文件夹。
通过创建一个FileSystemObject对象，我们可以访问文件系统的各种属性和方法，包括文件重命名。
下面是一个示例的VBA代码，用于将指定文件夹下的所有文件重命名：```Sub BatchRenameFiles()Dim fso As Scripting.FileSystemObjectDim folderPath As StringDim folder As Scripting.FolderDim file As Scripting.File' 设置文件夹路径folderPath = "C:\Path\to\folder\"' 创建FileSystemObject对象Set fso = New Scripting.FileSystemObject ' 获取文件夹对象Set folder = fso.GetFolder(folderPath)' 遍历文件夹下的所有文件For Each file In folder.Files' 对每个文件执行重命名操作 = "NewFileName" & Next file' 释放对象Set folder = NothingSet fso = NothingEnd Sub```3. 使用字符串处理函数VBA提供了一系列用于处理字符串的函数，我们可以利用这些函数来对文件名进行操作。
VBA中的文件夹批量重命名和操作技巧
VBA中的文件夹批量重命名和操作技巧在VBA中，文件夹批量重命名和操作是一项非常有用的技巧。
通过使用VBA 编写的宏，我们可以自动化地对文件夹内的所有文件进行重命名、复制、移动和删除等操作。
在这篇文章中，我们将探讨一些VBA中的文件夹批量重命名和操作技巧，帮助您更高效地管理和处理大量文件。
一、文件夹批量重命名批量重命名文件夹中的文件是一个常见的需求。
在VBA中，我们可以通过循环遍历文件夹中的每个文件，并使用FileSystemObject对象的Rename方法进行重命名。
下面是一个示例代码：```vbaSub BatchRenameFiles()Dim FolderPath As StringDim Folder As ObjectDim File As Object' 设置文件夹路径FolderPath = "C:\YourFolderPath"' 创建一个FileSystemObject对象Set Folder = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath) ' 循环遍历文件夹中的每个文件，并重命名For Each File In Folder.Files = "NewFileName" & Format(File.Index, "000") & File.ExtensionNext File' 清空对象Set Folder = NothingSet File = NothingMsgBox "文件夹中的文件已经成功重命名！"End Sub```这段代码首先定义了文件夹路径，然后通过CreateObject函数创建了一个FileSystemObject对象。
接下来，我们循环遍历文件夹中的每个文件，使用属性对文件进行重命名。
Excel VBA编程 典型实例——批量修改文件名
Excel VBA 编程 典型实例——批量修改文件名为了对计算机磁盘中的文件进行统一管理，可以对其进行批量重命名。
下面借助于Excel 2007中的控件及VBA 代码等知识，通过在Excel 工作表中的对应文件名进行修改，从而达到修改磁盘中的文件名的目的。
1．练习要点● 新建工作簿● 控件的应用2．操作步骤：（1）打开一个Excel 文件，并进入VBE 窗口。
然后，在新建的模块【代码】编辑窗口中，输入下面的代码，以创建工作簿。
Sub 新建工作簿()Workbooks.AddEnd Sub（2）在新建的工作簿中，创建如图15-7所示的表格。
图15-7 创建表格（3）进入VBE 窗口中，新建一个模块，在该模块【代码】编辑窗口中，输入如图15-8所示的代码。
创建表格输入图15-8 输入代码Dim obj As ObjectDim fld, ff, ggSub aa()Range("a2:c3000").ClearContentsOn Error Resume Nextgg = InputBox("请把要批量更名的文件夹地址粘贴或输入到下框中", , 100) Set obj = CreateObject("Scripting.FileSystemObject")Set fld = obj.GetFolder(gg)For Each ff In fld.Filesm = m + 1Cells(m + 1, 1) = Cells(m + 1, 2) = "-------"Cells(m + 1, 3) = NextEnd Sub————————————————Sub bb()On Error Resume NextIf [a2] = "" Then MsgBox "请点击第一步": Exit SubFor Each ff In fld.Filesm = m + 1 = Cells(m + 1, 3)NextMsgBox "改名已完成，请检查", vbOKOnlyEnd Sub（4）在工作表中，插入两个“按钮（窗体控件）”按钮，并分别重命名为“第一步：获取原文件名”和“第二步：改成新文件名”文字，如图15-9所示。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
前段时间，因编写报告，需要把成果图片修改名字后，将图以及相应的名字插入word文档中。
一次报告，至少200张图，花了数个小时才弄完工作，同时难免出现差错。
之后就一直寻找捷径，基于excel vba以前有一点基础，现将整理出来的代码分享给大家。
可以去下载我编好的excel 小程序，里面有详细代码，地址在最下方。
欢迎直接试用下，给个反馈建议.
1.查找文件夹中符合图片格式的文件，返回其名字
Dim fs, f, f1, fc, s
Dim arr As String
Set fs = CreateObject("")
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address))) '获得当前工作表所在文件夹路径
Set f = (Address)
Set fc =
i = 2
For Each f1 In fc '遍历文件
If FileIspicture Then ' 引用了自定义函数 FileIspicture 判断是否为需要查找的文件格式
phname = '获取文件名
houzhui = Right(phname, Len(phname) - InStrRev(phname, ".",
Len(phname)) + 1)
(i, 1) = Left(phname, InStrRev(phname, ".", Len(phname)) - 1) (i, 2) = houzhui
i = i + 1
End If
Next
2.修改文件名称
Sub changename()
Dim Address As String
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address)))
n = , 1).End(xlUp).row
For i = 2 To n '修改名称
pname = (i, 1) & (i, 2)
textname = (i, 3)
houzhui = Right(pname, Len(pname) - InStrRev(pname, ".", Len(pname)) + 1) '获取后缀
Name Address & pname As Address & textname & houzhui
Next i
MsgBox "名称已改"
End Sub
3.批量插图到word
Dim appWD As
Dim Address As String
myName = "" '新建的word名称
Address =
Address = Left(Address, InStrRev(Address, "\", Len(Address))) mydoc = Address & myName
On Error Resume Next '错误处理
Kill (mydoc)
On Error GoTo 0
On Error Resume Next
Set appWD = GetObject(, "")
SaveChanges:=wdDoNotSaveChanges
Set appWD = CreateObject("") '连接word
filename:=mydoc
= True
n = , 1).End(xlUp).row '获取工作表有效部分的最大行数
For i = 2 To n '插入图片
pname = (i, 1) & (i, 2)
textname = (i, 3)
filename:=Address & pname, LinkToFile:= _
False, SaveWithDocument:=True
Text:=textname
houzhui = Right(pname, Len(pname) - InStrRev(pname, ".", Len(pname)) + 1)
Next i
'居中，修改字体大小为10，字体加粗
= wdAlignParagraphCenter
= 10
= "宋体"
= wdToggle
4.修改图片大小，使每页正好两张图
Dim picwidth
Dim picheight
PictureToWord CSDN下载地址这个需要1积分PictureToWord RaySource下载地址这个免费。