历遍WORD表格，根据文字内容扣分

ww0000

jiminyanyan 发表于 2018-6-9 16:46
批量运行时，运行另外一个时候，x要先清零的……。

如何清？请教

jiminyanyan

ww0000 发表于 2018-6-9 17:26
如何清？请教

x=0   .....................

ww0000

jiminyanyan 发表于 2018-6-9 16:46
批量运行时，运行另外一个时候，x要先清零的……。

批量评分.zip (660.1 KB, 下载次数: 6)

2018-6-10 08:38 上传

点击文件名下载附件

x已先清零，但结果还是不对
执行代码，选择文件夹，里面三个文件一样的，但结果不一样，不知道为什么？

182197315

Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Document
myPath = ThisDocument.Path & "\"
myFile = Dir(myPath & "*.doc?")
Do While myFile <> ""
    If myFile <> ThisDocument.Name Then
        Set aDoc = Documents.Open(myPath & myFile)
        With aDoc.Tables(1)
            For i = 2 To .Rows.Count - 1
                sr1 = Replace(.Cell(i, 2).Range.Text, Chr(7), "")
                If sr1 Like "*保洁不到位*" Or sr1 Like "*零星垃圾*" Then
                    sr2 = "-0.5分"
                ElseIf sr1 Like "*卫生差*" Or sr1 Like "*乱搭盖*" Or sr1 Like "*乱张贴*" Or sr1 Like "*乱拉挂" Then
                    sr2 = "-1分"
                ElseIf sr1 Like "*垃圾堆积*" Or sr1 Like "*建筑垃圾*" Then
                    sr2 = "-2分"
                ElseIf sr1 Like "*陈年垃圾*" Or sr1 Like "*卫生死角*" Or sr1 Like "*焚烧垃圾*" Then
                    sr2 = "-3分"
                End If
                .Cell(i, 4).Range.Text = sr2
                x = x + Val(sr2)
            Next
            .Cell(.Rows.Count, 4).Range.Text = 100 + x & "分"
        End With
        aDoc.Close True
    End If
    myFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

ww0000

182197315 发表于 2018-6-10 10:35
Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Docu ...

结果不对唷

ww0000

182197315 发表于 2018-6-10 10:35
Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Docu ...

你文件夹里多复制几个一样的文件试试

182197315

Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Document
myPath = ThisDocument.Path & "\"
myFile = Dir(myPath & "*.doc?")
Do While myFile <> ""
    If myFile <> ThisDocument.Name Then
        x = 0: sr1 = "": sr2 = ""
        Set aDoc = Documents.Open(myPath & myFile)
        With aDoc.Tables(1)
            For i = 2 To .Rows.Count - 1
                sr1 = Replace(.Cell(i, 2).Range.Text, Chr(7), "")
                If sr1 Like "*保洁不到位*" Or sr1 Like "*零星垃圾*" Then
                    sr2 = "-0.5分"
                ElseIf sr1 Like "*卫生差*" Or sr1 Like "*乱搭盖*" Or sr1 Like "*乱张贴*" Or sr1 Like "*乱拉挂*" Then
                    sr2 = "-1分"
                ElseIf sr1 Like "*垃圾堆积*" Or sr1 Like "*建筑垃圾*" Then
                    sr2 = "-2分"
                ElseIf sr1 Like "*陈年垃圾*" Or sr1 Like "*卫生死角*" Or sr1 Like "*焚烧垃圾*" Then
                    sr2 = "-3分"
                End If
                .Cell(i, 4).Range.Text = sr2
                x = x + Val(sr2)
            Next
            .Cell(.Rows.Count, 4).Range.Text = 100 + x & "分"
        End With
        aDoc.Close True
    End If
    myFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

ww0000

182197315 发表于 2018-6-10 11:38
Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Docu ...

这下对了，原来x = 0: sr1 = "": sr2 = ""，三个全要归零

不过，
sr1 = Replace(.Cell(i, 2).Range.Text, Chr(7), "")
这样就行
sr1 = .Cell(i, 2).Range.Text

ww0000

182197315 发表于 2018-6-10 11:38
Sub aa()
Application.ScreenUpdating = False
Dim i%, sr1$, sr2$, x!, myPath$, myFile$, aDoc As Docu ...

又遇到一个新问题，如何排除只有文字，但没有图片的单元格（判断单元格是否有图片），如果没图片，后面就不打分