批量修改格式问题，求救~~~~

swj54006 · 发表于 2021-5-15 20:09

将 word文件内 推荐的中标候选人和中标人下面单元格内的字体调整为20号字，

如何用vba批量实现

413191246se · 发表于 2021-5-16 01:36

* 楼主，请将要处理的文件放入一个文件夹中，打包（或复制）备份后，应用下面的宏：

Sub LoopFolder_duquancai_2021_05_16()
Dim SelectFolder$
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then SelectFolder = .SelectedItems(1) & "" Else End
End With
If MsgBox("是否处理文件夹 " & """" & SelectFolder & """" & " ?", 4 + 16) = vbNo Then End
Dim pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
pPath = SelectFolder
Set fso = CreateObject("Scripting.FileSystemObject")
top = 1
ReDim Stack(0 To top)
Do While top >= 1
For Each f In fso.getFolder(pPath).Files
n = n + 1
stxt = f.Path
If stxt Like "*.doc*" Then
Set doc = Documents.Open(FileName:=stxt)
ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
With doc.Content.Find
.ClearFormatting
.Text = "推荐的中标候选人和中标人"
.Forward = True
.MatchWildcards = True
Do While .Execute
With .Parent
.Select
With Selection
With .Font
.Parent.MoveRight Unit:=wdCell, Count:=8
.NameFarEast = "华文中宋"
.NameAscii = "Times New Roman"
.Size = 20
.Bold = True
.ColorIndex = wdRed
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.HomeKey 6
End With
End With
Loop
End With
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
Next
For Each fd In fso.getFolder(pPath).subFolders
Stack(top) = fd.Path
top = top + 1
If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
Next
If top > 0 Then pPath = Stack(top - 1): top = top - 1
Loop
Set f = Nothing
Set fd = Nothing
Set fso = Nothing
MsgBox "文件夹包含 " & n & " 个文件！" & vbCr & "共处理 Word 文档(*.docx/*.doc) " & x & " 个！", 0 + 48
End Sub

复制代码

swj54006 · 发表于 2021-5-16 23:42

413191246se 发表于 2021-5-16 01:36
* 楼主，请将要处理的文件放入一个文件夹中，打包（或复制）备份后，应用下面的宏：

这是我研究的笨办法，先拆分成统一的表格，然后查找到对应的单元格，在进行处理
Private Sub CommandButton2_Click()
Dim WdApp As Object
Dim objTable As Object
Dim objDoc As Object
Set objDoc = ActiveDocument
   ’先在表头增加一行空白行
For Each objTable In objDoc.Tables
'遍历文档中的每个表格
      k = k + 1
      x = objTable.Rows.Count
      'y = objTable.Columns.Count
      b = objTable.Cell(1, 1).Range.Text
For i = x To 2 Step -1
      bb = objTable.Cell(i, 1).Range.Text
   If bb = b Then
      objTable.Cell(i, 1).Range.Select
      Selection.InsertBreak Type:=wdSectionBreakContinuous
      End If
   Next
   Next
For Each objTable In objDoc.Tables
'遍历文档中的每个表格
   objTable.Cell(5, 8).Range.Font.Size = 20
Next
End Sub

tcdatongye · 发表于 2021-5-17 10:50

Sub 替换()
With ActiveDocument
k = .Tables.Count
For i = 1 To k
With .Tables(i)
m = .Rows.Count
For j = 1 To m
.Cell(j, 1).Select
Selection.EndOf unit:=wdRow
Selection.Cells(1).Select
s1 = Selection.Information(wdEndOfRangeRowNumber)
s2 = Selection.Cells(1).RowIndex
If s1 > s2 Then
Selection.Font.Size = 20
End If
Next j
End With
Next i
End With
End Sub

复制代码

		自动登录	找回密码
密码			免费注册