|
在Excel中创建并操作word文档时出错,在下面的代码的水红色处。
请大侠帮我一看。
Private Sub CommandButton1_Click()
Dim Wrd As New Word.Application
Dim par As Paragraph
Set d = CreateObject("scripting.dictionary")
For j = 3 To 45
If ActiveSheet.Cells(3, j) <> 0 Then
For i = 4 To 485
If ActiveSheet.Cells(i, j) = "×" Then sr = sr & ActiveSheet.Cells(i, 3).Value & Chr(13)
Next
d.Add ActiveSheet.Cells(2, j).Text, sr
End If
sr = ""
Next
k = d.keys
t = d.Items
ct = d.Count
For i = 1 To ct - 1
sr1 = IIf(i <> 1, Chr(12), "")
isr = isr & sr1 & k(i) & " 词语更错集" & Chr(13) & t(i)
Next
Set wd = Wrd.Documents.Add
With wd
.Content.Text = isr
.Content.Font.Name = "楷体"
.Content.Font.Name = "Arial Narrow"
'以下为对新文档的后期处理
With .PageSetup '页面设置
.TopMargin = MillimetersToPoints(15)
.BottomMargin = MillimetersToPoints(15)
.LeftMargin = MillimetersToPoints(16)
.RightMargin = MillimetersToPoints(18)
End With
'预处理
With .Content.Find
.Execute "^13", , , , , , , , , "^p", 2
.Execute "^11", , , , , , , , , "^p", 2
.Parent.ListFormat.ConvertNumbersToText
End With
'Sub 删除空行()
For Each par In ActiveDocument.Paragraphs
If Asc(par.Range) = 13 Then par.Range.Delete
Next
With Selection
.HomeKey 6 '此为出错的地方,不知道是什么原因,请大侠看看。
Do
.MoveEndUntil cset:=Chr(12), Count:=wdForward
If Len(.Text) = 1 Then .EndKey 6, 1
.MoveStart 4, 1
With .Previous(4, 1)
With .Font
.Name = Choose(Int(Rnd * 6 + 1), "黑体", "华文隶书", "华文新魏", "方正苏新诗柳楷简体", "方正康体简体", "华文中宋", "方正康体简体")
.Size = 18
.Bold = True
.ColorIndex = Choose(Int(Rnd * 6 + 1), wdViolet, wdPink, wdGreen, wdDarkYellow, wdDarkBlue, wdBlack, wdBrightGreen)
'.Color = wdColorRed
End With
With .ParagraphFormat
.SpaceBefore = 24
.SpaceAfter = 24
.Alignment = wdAlignParagraphCenter
.Space15
End With
End With
ActiveDocument.Range(Start:=.Start, End:=.Start).InsertBreak Type:=wdSectionBreakContinuous
.Start = .Start + 1
If Not .End = ActiveDocument.Content.End Then ActiveDocument.Range(Start:=.End, End:=.End).InsertBreak Type:=wdSectionBreakContinuous
With .PageSetup.TextColumns
.SetCount NumColumns:=4 '四栏
.EvenlySpaced = True '等宽
.Width = MillimetersToPoints(33) '栏宽
.Spacing = MillimetersToPoints(2.5) '栏间距
End With
.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1)
.TrailingCharacter = wdTrailingNone
With .Font
.ColorIndex = 9
.Size = 6
.Bold = True
.Name = "方正姚体"
End With
End With
If .End = ActiveDocument.Content.End Then .HomeKey 6: Exit Sub
.Next.Next.Next.Select
Loop
End With
.SaveAs Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & "[更错版]" & ".docx"
End With
End Sub附件如下:
|
|