用vba实施段落重新排序？

wonyee

各位大神：

我的word文本如下：

Hepatitis B virus, or Hep B virus for short, is a member of the hepadnavirus family
Hepatitis D virus, or Hep D virus, is a deltavirus.
They both cause hepatitis, or inflammation of the liver.
Even though they both cause hepatitis, hepatitis D virus cannot cause the disease by itself, and needs hepatitis B virus to replicate.
乙型肝炎病毒，或简称Hep B virus，是肝炎病毒家族的成员
丁型肝炎病毒是一种δ病毒。
它们都会引起肝炎或肝脏炎症。
即使它们都会引起肝炎，丁型肝炎病毒也不能单独引起疾病，需要乙型肝炎病毒来复制。


我希望变成每段落中英相间，如下：


Hepatitis B virus, or Hep B virus for short, is a member of the hepadnavirus family
乙型肝炎病毒，或简称Hep B virus，是肝炎病毒家族的成员
Hepatitis D virus, or Hep D virus, is a deltavirus.
丁型肝炎病毒是一种δ病毒。
They both cause hepatitis, or inflammation of the liver.
它们都会引起肝炎或肝脏炎症。
Even though they both cause hepatitis, hepatitis D virus cannot cause the disease by itself, and needs hepatitis B virus to replicate.
即使它们都会引起肝炎，丁型肝炎病毒也不能单独引起疾病，需要乙型肝炎病毒来复制。


该如何实现呢？VBA?

limonet

代码要审核

limonet

Sub 宏1()
    Dim P As Paragraph, i%
    With CreateObject("scripting.dictionary")
        i = 1
        For Each P In ActiveDocument.Paragraphs
            If Left(P.Range.Text, 1) Like "[A-Z]" Then
                .Item(i) = P.Range.Text
                i = i + 2
            End If
        Next P
        i = 2
        For Each P In ActiveDocument.Paragraphs
            If Left(P.Range.Text, 1) Like "[A-Z]" = False Then
                .Item(i) = P.Range.Text
                i = i + 2
            End If
        Next P
        For i = 1 To .Count
            ActiveDocument.Paragraphs(i).Range.Text = .Item(i)
        Next i
    End With
End Sub

wonyee

多谢兄台！我改进了一下，效果会好一些：

Sub aaaa_中英相间()
    Dim P As Paragraph, i%, j%, pc%
    pc = ActiveDocument.Paragraphs.Count
    If Not pc Mod 2 = 0 Then Exit Sub '如果段落数不是偶数，退出
    With CreateObject("scripting.dictionary")
        i = 1
        For j = 1 To pc Step 2
                .Item(i) = ActiveDocument.Paragraphs((j + 1) / 2).Range.Text '奇数段
                .Item(i + 1) = ActiveDocument.Paragraphs((j + 1) / 2 + pc / 2).Range.Text '偶数段
                i = i + 2
        Next
        For i = 1 To .Count
            ActiveDocument.Paragraphs(i).Range.Text = .Item(i)
        Next i
    End With
End Sub

常扬帆

下载你们的文件可以，我的文件，两种版本都不行呢？(.docx和.docm)

常扬帆

沉下去了，把它捞上来。5楼的怎么就不行呢？

413191246se

楼上朋友，问题出在“手动换行符^l”和最后一段是空白段落这两个毛病上。你运行一下下面的小宏，再运行 4 楼代码就 OK 了！

1. Sub a0904_prepare_Chinese_English()
   
2.     With ActiveDocument
   
3.         .Content.Find.Execute "^l", , , 0, , , , , , "^p", 2
   
4.         Do While .Paragraphs.Last.Range.Text = vbCr
   
5.             .Paragraphs.Last.Range.Delete
   
6.         Loop
   
7.     End With
   
8. End Sub

复制代码

常扬帆

413191246se 发表于 2022-9-4 02:32
楼上朋友，问题出在“手动换行符^l”和最后一段是空白段落这两个毛病上。你运行一下下面的小宏，再运行 4  ...

衷心感谢！原来是“^l”在作怪。