word VBA 选择题根据选项长度自动排版！求助

zhanglei1371

付费后可以做的更详细，^-^.^-^

wdpfox

ming0018 发表于 2019-3-12 16:04
拿去玩吧

请问老师：Rng.ComputeStatistics(1) > 1代码是什么意思？谢谢！

wdpfox

应该是统计行数。

betelehe

ming老师的代码精妙无比，测试长文档非常好用。
还有个小疑问，如果是理科试卷，选项中含有上下标的时候，运行完代码会将上下标取消掉。
有没有老师能改一下代码，使得既满足楼主的要求，又不干扰选项中的上下标。

wdpfox

ming0018 发表于 2019-3-12 16:04
拿去玩吧

在ming0018教师代码的基础上，完善一下排版情况，请老师勿责怪：
Sub main()
   
    Dim doc As Document, Rng As Range, arr, lineCount%
    Set doc = ActiveDocument: lineCount = 40
    With doc.Content.Find
        
        .Text = "A．[!^13]{1,}^13^13B．[!^13]{1,}^13^13C．[!^13]{1,}^13^13D．[!^13]{1,}^13"
        .MatchWildcards = True
        
        Do While .Execute
            
            Set Rng = .Parent
            Rng.Text = Replace(Rng.Text, Chr(13) & Chr(13), Chr(13))
            
            If Len(Rng.Text) < lineCount Then
               
                Rng.MoveEnd 1, -1
                Rng.Text = Replace(Rng.Text, Chr(13), vbTab)
                If Rng.ComputeStatistics(1) > 1 Then
                doc.Undo
                End If
               
            ElseIf Len(Rng.Text) < lineCount * 3 Then
               
                arr = Split(Rng.Text, Chr(13))
               
                If Len(arr(0)) + Len(arr(1)) < lineCount - 2 And Len(arr(2)) + Len(arr(3)) < lineCount - 2 Then
                    
                    Rng.Text = arr(0) & vbTab & arr(1) & Chr(13) & arr(2) & vbTab & arr(3) & Chr(13)
                    If Rng.ComputeStatistics(1) > 2 Then
                        doc.Undo
                    End If
                    
                ElseIf Len(arr(0)) + Len(arr(1)) < lineCount - 2 And Len(arr(2)) + Len(arr(3)) > lineCount - 2 Then
                    
                    Rng.Text = arr(0) & vbTab & arr(1) & Chr(13) & arr(2) & Chr(13) & arr(3) & Chr(13)
                    
                ElseIf Len(arr(0)) + Len(arr(1)) > lineCount - 2 And Len(arr(2)) + Len(arr(3)) < lineCount - 2 Then
                    
                    Rng.Text = arr(0) & Chr(13) & arr(1) & Chr(13) & arr(2) & vbTab & arr(3) & Chr(13)
                    
                ElseIf Len(arr(1)) + Len(arr(2)) < lineCount - 2 And Len(arr(2)) + Len(arr(3)) < lineCount - 2 Then
                    
                    Rng.Text = arr(0) & Chr(13) & arr(1) & Chr(13) & arr(2) & vbTab & arr(3) & Chr(13)
                    
                ElseIf Len(arr(1)) + Len(arr(2)) < lineCount - 2 And Len(arr(2)) + Len(arr(3)) > lineCount - 2 Then
                    
                    Rng.Text = arr(0) & Chr(13) & arr(1) & vbTab & arr(2) & Chr(13) & arr(3) & Chr(13)
                    
                End If
            End If
            Rng.Move 4
        Loop
    End With
   
End Sub

We meet by chance like patches of drifting duckweed,  
May everything be fine with you everyday !
  （你我萍水相逢，愿君一切安好！）