|
|
初学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 |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-2-5 12:35
楼主
