如何把英语句子拆分成单词任意排列

zzpsx

Chip_Kenny 发表于 2020-5-23 10:56
先選定範圍後執行

非常流畅的代码，两个地方能完善就更好了。1.能保留原来的所有句子，拆解后的所有单词放在原文下面。

He is a nice boy.
They are from China.

is he boy a nice
from they China are

2.原句中的专有名词在拆解后，希望能保留首字母大写的格式，如American,I等

Chip_Kenny

1. Sub zz()
   
2. Dim Mytxt, Mysentence, c As New Collection, n&, s$, a
   
3. a = Selection
   
4. Mysentence = Split(LCase(a), Chr(13))
   
5. For i = 0 To UBound(Mysentence)
   
6. If Len(Mysentence(i)) = 0 Then GoTo 1000
   
7. Set c = Nothing
   
8. Mytxt = Split(Trim(Mysentence(i)), " ")
   
9. s = Right(Mytxt(UBound(Mytxt)), 1)
   
10. Mytxt(UBound(Mytxt)) = Replace(Mytxt(UBound(Mytxt)), s, "")
    
11. For j = 0 To UBound(Mytxt)
    
12. c.Add Mytxt(j)
    
13. Next
    
14. For j = 1 To c.Count
    
15. n = Int((c.Count * Rnd) + 1)
    
16. Mytxt(j - 1) = c(n)
    
17. c.Remove (n)
    
18. Next
    
19. Mytxt(j - 2) = Mytxt(j - 2) & s
    
20. Mysentence(i) = Join(Mytxt, " ")
    
21. 1000
    
22. Next
    
23. Documents.Add DocumentType:=wdNewBlankDocument
    
24. a = a & Chr(13) & Chr(13) & Join(Mysentence, Chr(13))
    
25. Selection = a
    
26. End Sub

复制代码

zzpsx

Chip_Kenny 发表于 2020-5-25 10:29

If Left(Z(0), 2) <> "I'" And Z(0) <> "I" Then Z(0) = LCase(Z(0)) '加上这一句可保留非首单词的大写
以上是excel中的一段代码，可以用在word中吗？

完整代码：
Sub Lr()
  Application.ScreenUpdating = False
  Ar = Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
  For I = 1 To UBound(Ar)
    Ar(I, 1) = Trim(Ar(I, 1))
    Bd = Right(Ar(I, 1), 1)
    Z = Split(Left(Ar(I, 1), Len(Ar(I, 1)) - 1))
     If Left(Z(0), 2) <> "I'" And Z(0) <> "I" Then Z(0) = LCase(Z(0)) '加上这一句可保留非首单词的大写
    X = Z
    Set D0 = CreateObject("Scripting.Dictionary")
    Randomize
    Do
      M = Int(((UBound(Z) + 1) * Rnd) + 1)
      If Not D0.Exists(M) Then D0(M) = ""
    Loop Until D0.Count = UBound(Z) + 1 Or UBound(Z) = 0
    Y = D0.Keys
    For J = 0 To UBound(Y)
      X(Y(J) - 1) = Z(J)
    Next
    Cells(I, 3) = Join(X, " ") & Bd
  Next I
  Application.ScreenUpdating = True
End Sub