把句子拆分成单词的代码怎么写？

zzpsx

如何把句子拆解成单词.rar (3.52 KB, 下载次数: 5)

2019-7-1 20:21 上传

点击文件名下载附件

zzpsx

Sub 拆句成词()
Dim s$, b(), n, t As Boolean
    For k = 1 To ActiveDocument.Paragraphs.Count
        s = ActiveDocument.Paragraphs(k).Range
        If Len(s) < 2 Then
        Else
            With CreateObject("vbscript.regexp")
                .Pattern = "[^\w ]+"
                .Global = True
                a = Split(.Replace(LCase(s), ""), " ")
                ReDim b(UBound(a), 1)
                For i = 0 To UBound(a)
                    b(i, 0) = Rnd(): b(i, 1) = a(i)
                Next
                For i = 0 To UBound(b) - 1
                    n = b(i, 0)
                    For j = i + 1 To UBound(b)
                        If n > b(j, 0) Then n = b(j, 0): jj = j: t = True
                    Next
                    If t Then
                        t = False
                        For j = 0 To 1
                            n = b(i, j): b(i, j) = b(jj, j): b(jj, j) = n
                        Next
                    End If
                Next
                For i = 0 To UBound(a)
                    a(i) = b(i, 1) & "  "
                Next
                ActiveDocument.Paragraphs(k).Range.Text = ""
               
                Set oRng = ActiveDocument.Range(ActiveDocument.Paragraphs(k).Range.Start, ActiveDocument.Paragraphs(k).Range.Start)
                oRng.Text = Join(a, ",") & Chr(13)
            End With
        End If
    Next
End Sub


以上是我手头的拆解代码，但还不够完善。

413191246se

楼主，你希望的效果，取词顺序有何依据？

纳铭

'引用两个Dll

Function ResultABC(strSource As String) As String
    Dim objRegexp As New RegExp
   
    With objRegexp
        .Global = True
        .MultiLine = False
        .IgnoreCase = True
   
    '-----去掉一句话最后的标点符号 需要后面补充
        .Pattern = "(\.|\?)$"
        strSource = .Replace(strSource, "")
        
    '-----获取所有非空值
        .Pattern = "[^\s]{1,}"
        If .test(strSource) Then
            'Debug.Print .Execute(strSource).Count
            
            '------一些声明与设置
            ReDim Arr(0 To .Execute(strSource).Count - 1)
            Dim lgI As Long
            Dim objDic As New Dictionary
            objDic.CompareMode = BinaryCompare '区分大小写
                       
                       
            '------单词储存在数组中
            For lgI = 0 To .Execute(strSource).Count - 1
                Dim strWord As String: strWord = .Execute(strSource)(lgI)
                If Not objDic.Exists(strWord) Then objDic.Add strWord, ""
                Arr(lgI) = strWord
            Next
            
            
            '------排除特殊情况
            If objDic.Count = 1 Then ResultABC = "仅有一个单词": GoTo EXIT_FUNCTION
            
            
            '------打乱数组
            Dim Arr2: Arr2 = Arr
            Do While Join(Arr, " , ") = Join(Arr2, " , ")
                Arr2 = Arr
                ExchangeArr Arr
            Loop
            
            ResultABC = Join(Arr, " , ")
        Else
            ResultABC = "无单词": GoTo EXIT_FUNCTION
        End If
        
        
    End With
EXIT_FUNCTION:
End Function



Function ExchangeArr(Arr)
    Dim lgI As Long
    For lgI = LBound(Arr) To UBound(Arr)
        Dim lgNumber As Long: lgNumber = WorksheetFunction.RandBetween(LBound(Arr), UBound(Arr))
        If lgI <> lgNumber Then
            Dim strTemp As String: strTemp = Arr(lgI)
            Arr(lgI) = Arr(lgNumber)
            Arr(lgNumber) = strTemp
        End If
    Next
End Function



我是在Excel里做的
你尝试下把它弄到Word中
如果哪里不清晰的 可以直接问我

小花鹿

不就是空格拆分吗，是我理解错了？                                                                                 

daibao88

用Words对象就行，对英文还是正确的，中文有时不正确。
Range.Words 属性
返回一个 Words 集合，该集合代表范围中的所有单词

tangqingfu

纳铭 发表于 2019-7-2 07:55
'引用两个Dll

Function ResultABC(strSource As String) As String

感谢分享，收藏学习！