word根据条件判断 求代码

cjy964

excel玉米

mark一下，应该可以用书签+域解决的

凌空一羽

Sub lkyy()
Dim doc As Document, ar(1 To 33), tb As Table
Set doc = ActiveDocument
doc.Content.Find.Execute "^p√", , , , , , , , , "", 2
For i = 1 To 3
    For j = 1 To 11
        n = n + 1
        ar(n) = Split(Replace(doc.Tables(3).Cell(i * 2, j).Range.Text, Chr(7), ""), Chr(13))(0)
    Next
Next

For i = 1 To 21
    s = Replace(Replace(doc.Tables(1).Cell(i, ar(i) + 1).Range.Text, Chr(7), ""), Chr(13), "")
    doc.Tables(1).Cell(i, ar(i) + 1).Range = s & Chr(13) & "√"
Next
For i = 22 To 33
    s = Replace(Replace(doc.Tables(2).Cell(i - 21, ar(i) + 1).Range.Text, Chr(7), ""), Chr(13), "")
    doc.Tables(2).Cell(i - 21, ar(i) + 1).Range = s & Chr(13) & "√"
Next
End Sub

cjy964

凌空一羽 发表于 2020-2-6 11:29
Sub lkyy()
Dim doc As Document, ar(1 To 33), tb As Table
Set doc = ActiveDocument

谢谢了  

excel玉米

凌空一羽 发表于 2020-2-6 11:29
Sub lkyy()
Dim doc As Document, ar(1 To 33), tb As Table
Set doc = ActiveDocument

初学word的vba,接着凌空一羽的代码，编写完成余下的工作。

Sub lkyy()
Dim doc As Document, ar(1 To 33), tb As Table, k(2 To 10)
Set doc = ActiveDocument
doc.Content.Find.Execute "^p√", , , , , , , , , "", 2
For i = 1 To 3
    For j = 1 To 11
        n = n + 1
        ar(n) = Split(Replace(doc.Tables(3).Cell(i * 2, j).Range.Text, Chr(7), ""), Chr(13))(0)
    Next
Next
For i = 2 To 22
    s = Replace(Replace(doc.Tables(1).Cell(i, ar(i - 1) + 1).Range.Text, Chr(7), ""), Chr(13), "")
    doc.Tables(1).Cell(i, ar(i - 1) + 1).Range = s & Chr(13) & "√"
Next
For i = 22 To 33
    s = Replace(Replace(doc.Tables(2).Cell(i - 21, ar(i) + 1).Range.Text, Chr(7), ""), Chr(13), "")
    doc.Tables(2).Cell(i - 21, ar(i) + 1).Range = s & Chr(13) & "√"
Next
With doc.Tables(3)
   k(2) = getleft(2, 2) + getleft(2, 3) + getleft(2, 4) + getleft(4, 3)     '气虚质
   k(3) = getleft(2, 11) + getleft(4, 1) + getleft(4, 2) + getleft(6, 7)    '阳虚质
   k(4) = getleft(2, 10) + getleft(4, 10) + getleft(6, 4) + getleft(6, 9)   '阴虚质
   k(5) = getleft(2, 9) + getleft(4, 5) + getleft(6, 6) + getleft(6, 10)    '痰湿质
   k(6) = getleft(6, 1) + getleft(6, 3) + getleft(6, 5) + getleft(6, 8)     '湿热质
   k(7) = getleft(4, 8) + getleft(4, 11) + getleft(6, 2) + getleft(6, 11)   '血瘀质
   k(8) = getleft(2, 5) + getleft(2, 6) + getleft(2, 7) + getleft(2, 8)     '气瘀质
   k(9) = getleft(4, 4) + getleft(4, 6) + getleft(4, 7) + getleft(4, 9)     '特禀质
   k(10) = getleft(2, 1) + 24 - (getleft(2, 2) + getleft(2, 4) + getleft(2, 5) + getleft(4, 2))   '平和质
End With
With doc.Tables(2)
   For m = 2 To 10
    With .Cell(14, m)
     With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ":?"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True ''表明使用通配符
        .Execute Replace:=wdReplaceAll
    End With
      .Range.Find.Execute "√", , , , , , , , , "", 2
      .Range.Find.Execute "╳", , , , , , , , , "", 2
     End With
    Next
End With
With doc.Tables(2)
For m = 2 To 9
    With .Cell(14, m)
      .Range.Find.Execute findText:="得分", ReplaceWith:="得分:" & k(m), Replace:=wdReplaceAll
      If k(m) >= 11 Then
       .Range.Find.Execute findText:=Chr(32) & "是", ReplaceWith:=Chr(32) & "是√", Replace:=wdReplaceAll
      ElseIf k(m) >= 9 And k(m) <= 10 Then
       .Range.Find.Execute findText:="倾向是", ReplaceWith:="倾向是√", Replace:=wdReplaceAll
      ElseIf k(m) <= 8 Then
        .Range.Find.Execute findText:=Chr(32) & "是", ReplaceWith:=Chr(32) & "是╳", Replace:=wdReplaceAll
        .Range.Find.Execute findText:="倾向是", ReplaceWith:="倾向是╳", Replace:=wdReplaceAll
      End If
    End With
  Next
    With .Cell(14, 10)
         .Range.Find.Execute findText:="得分", ReplaceWith:="得分:" & k(10), Replace:=wdReplaceAll
      If k(10) >= 17 And k(9) < 8 And k(2) < 8 And k(3) < 8 And k(4) < 8 And k(5) < 8 And k(6) < 8 And k(7) < 8 And k(8) < 8 Then
         .Range.Find.Execute findText:=Chr(32) & "是", ReplaceWith:=Chr(32) & "是√", Replace:=wdReplaceAll
      ElseIf k(10) >= 17 And 10 < k(9) < 8 And 10 < k(2) < 8 And 10 < k(3) < 8 And 10 < k(4) < 8 And 10 < k(5) < 8 And 10 < k(6) < 8 And 10 < k(7) < 8 And 10 < k(8) < 8 Then
          .Range.Find.Execute findText:="倾向是", ReplaceWith:="倾向是√", Replace:=wdReplaceAll
      Else
         .Range.Find.Execute findText:=Chr(32) & "是", ReplaceWith:=Chr(32) & "是╳", Replace:=wdReplaceAll
         .Range.Find.Execute findText:="倾向是", ReplaceWith:="倾向是╳", Replace:=wdReplaceAll
      End If
    End With
End With
End Sub
Function getleft(one As Integer, two As Integer)
   Dim doc As Document
   Set doc = ActiveDocument
  With doc.Tables(3)
   getleft = Val(Left(.Cell(one, two).Range, Len(.Cell(one, two).Range) - 1))
  End With
End Function

cjy964

excel玉米 发表于 2020-2-8 13:14
初学word的vba,接着凌空一羽的代码，编写完成余下的工作。

Sub lkyy()

谢谢 ，更加完美