VBA如何实现重复每一行

sqhsqhli

要实现的目标：
n行和n+1行的文字是一样的，n行设置一种书法字体，n+1行设置另一种书法字体

程序设计目标：
对行自动复制，并设置字体1，字体2

小花鹿

宁愿截图也不肯上附件

sqhsqhli

将 413191246se 的代码改了改，设置三种不同字体，感谢啦

Sub LoopLine()
Application.ScreenUpdating = False
Dim i As Integer
Dim y As Integer
ActiveDocument.Range(0, ActiveDocument.Content.End).Font.Size = 20
左对齐
左对齐
    ' 在整个文档中查找换行符（^l），并替换为段落标记（^p）
    ActiveDocument.Content.Find.Execute FindText:="^l", ReplaceWith:="^p", _
        Replace:=wdReplaceAll, MatchCase:=False, MatchWholeWord:=False, _
        MatchWildcards:=False, MatchSoundsLike:=False, MatchAllWordForms:=False, _
        Forward:=True, Wrap:=wdFindContinue, Format:=False
   
    ' 在光标位置插入一个空段落
    ActiveDocument.Content.InsertParagraphAfter
   
    ' 选择整个文档内容
    With Selection
        .WholeStory
        
        ' 执行 "删除行号" 命令
        CommandBars.FindControl(ID:=122).Execute
        
        ' 清除格式
     '   .ClearFormatting
        
        ' 将光标移到段落开头
        .HomeKey 6
        
        ' 重复执行直到到达文档结尾前一个字符
        Do
            ' 将光标移动到当前段落的结尾
            .EndKey 5, 1
            
            ' 在段落末尾插入当前段落的文本内容
            .InsertAfter Text:=vbCrLf & .Text & vbCrLf & .Text & vbCrLf
            
            ' 将光标向右移动一个字符位置
            .MoveRight
        Loop Until .End = ActiveDocument.Content.End - 1
    End With
  ' 删除空行
    ActiveDocument.Content.Find.Execute FindText:="^p^p", ReplaceWith:="^p", _
        Replace:=wdReplaceAll, MatchCase:=False, MatchWholeWord:=False, _
        MatchWildcards:=False, MatchSoundsLike:=False, MatchAllWordForms:=False, _
        Forward:=True, Wrap:=wdFindContinue, Format:=False
左对齐
左对齐
i = ActiveDocument.Paragraphs.Count
For y = 1 To i Step 1
If y Mod 3 = 2 Then
ActiveDocument.Paragraphs(y).Range.Font.Name = "书体坊文征明行草 简"
ElseIf y Mod 3 = 0 Then
ActiveDocument.Paragraphs(y).Range.Font.Name = "方正文征明行草 简"
  Else
ActiveDocument.Paragraphs(y).Range.Font.Name = "全新硬笔行书简"
  End If
Next
End Sub

Sub 左对齐()
    With ActiveDocument.Range.ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphJustify
        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
        .AutoAdjustRightIndent = True
        .DisableLineHeightGrid = False
        .FarEastLineBreakControl = True
        .WordWrap = True
        .HangingPunctuation = True
        .HalfWidthPunctuationOnTopOfLine = False
        .AddSpaceBetweenFarEastAndAlpha = True
        .AddSpaceBetweenFarEastAndDigit = True
        .BaseLineAlignment = wdBaselineAlignAuto
    End With
End Sub

413191246se

楼主 可以试试可否在第三行复制行下加一条下划线，那样欣赏起来就更明晰了！