[求助]求高手对VBA代码改进

dbzmc

非常不好意思,还要求朋友帮忙.

很感谢sylun大侠帮忙,对WORD问卷实现了批量处理,并且统计出了,每道题目的情况.具体请见:[求助]WORD中查找固定格式的文字

由于我当时不了解具体要求，没有把意思说明白,现在再请大家帮忙.希望在sylun大侠原有的代码基础上进行修改满足一下要求:

因为要做统计分析,有新的要求.希望统计出来的结果不是总数,而是具体到每个问卷的每道题目的回答情况.具体来说就是创建一个EXCEL文件,在这个EXCEL文件中每份问卷答案都单独占一行,具体数据模板见附件.谢谢

kSu4o5pQ.rar (10.5 KB, 下载次数: 15)

2007-5-20 23:33 上传

点击文件名下载附件
[求助]求高手对VBA代码改进

sylun

在原基础上勉强做了出来，看看是否合适。因首次对excel进行VBA操作,水平很有限，估计做法不怎么规范，也未作进一步处理。
Sub test2()
'请将所有问卷文档保存于指定的文件夹（暂定为E:\ddd）
    Dim ndoc As String, odoc As Document
    Dim mytext As String, info() As String
    Dim i As Integer, n As Integer, c As Integer
    Dim AppExcel As Excel.Application, myWbook As Excel.Workbook

    ChDrive "E" '设置当前驱动器
    ChDir "E:\ddd" '确定目录路径
    ndoc = Dir("*.doc")
    Application.ScreenUpdating = False
    Do While ndoc <> ""  '在指定目录内各文档循环操作
        n = n + 1
        Set odoc = Documents.Open(ndoc)
        With odoc.Content.Find '查找红色数字
            .ClearFormatting
            .Font.Color = wdColorRed
            .Format = True
            .MatchWildcards = True
            '如果找到，则记录其题号及数字选项
            Do While .Execute(findtext:="[1-3]", Forward:=True) = True
                With .Parent
                    mytext = mytext & Replace(odoc.Name, ".doc", "") _
                        & ":no" & .Cells(1).RowIndex - 1 & vbTab & .Text & vbCr
                    .Move Unit:=wdRow, Count:=1
                End With
            Loop
        End With
        '字符串中每个文件的记录数据以“|”分隔
        mytext = mytext & "|"
        odoc.Close False
        ndoc = Dir()
    Loop
    '将全部答卷记录数据按每份答卷作为一个元素生成数组，在excel表格中每元素数据占一行
    info = Split(Left(mytext, Len(mytext) - 1), "|")
    '创建excel文档并插入全部记录数据
    Set AppExcel = CreateObject("Excel.Application")
    AppExcel.Visible = True
    Set myWbook = AppExcel.Workbooks.Add
    With myWbook.ActiveSheet
        .Cells(1, 1).Value = "文件名"
        For i = 1 To 32
            .Cells(1, i + 1).Value = "No." & i
        Next i
        For c = 0 To UBound(info)
            .Cells(c + 2, 1).Value = Split(info(c), ":no")(0)
            For i = 1 To 32
                .Cells(c + 2, Split(Split(info(c), "no")(i), vbTab)(0) + 1).Value = Right(Split(info(c), vbCr)(i - 1), 1)
            Next i
        Next c
    End With
    Set AppExcel = Nothing
    Application.ScreenUpdating = True
    MsgBox "共统计了" & n & "个文档。", vbInformation
End Sub

[此贴子已经被作者于2007-5-21 13:56:54编辑过]

sylun

作为练习，试用另一种方法处理，进行多文档处理时不知哪种效果好点：
Sub test3()
'请将所有问卷文档保存于指定的文件夹（暂定为E:\ddd）
    Dim ndoc As String, odoc As Document, i As Integer, n As Integer
    Dim AppExcel As Excel.Application, myWbook As Excel.Workbook

    Application.ScreenUpdating = False
    '创建一个Excel空白文档
    Set AppExcel = CreateObject("Excel.Application")
    AppExcel.Visible = True
    Set myWbook = AppExcel.Workbooks.Add
    With myWbook.ActiveSheet
        .Cells(1, 1).Value = "文件名"
        For i = 1 To 32
            .Cells(1, i + 1).Value = "No." & i
        Next i
    End With
    ChDrive "E" '设置当前驱动器
    ChDir "E:\ddd" '确定目录路径
    ndoc = Dir("*.doc")
    Do While ndoc <> ""  '在指定目录内各文档循环操作
        n = n + 1
        Set odoc = Documents.Open(ndoc)
        myWbook.ActiveSheet.Cells(n + 1, 1).Value = Left(odoc, Len(odoc) - 4)
        For i = 2 To 33
            odoc.Content.Tables(1).Cell(i, 2).Range.Select '在第2列的每题单元格查找
            With Selection.Find '查找红色数字
                .ClearFormatting
                .Font.Color = wdColorRed
                .Format = True
                .MatchWildcards = True
                .Wrap = wdFindStop
                If .Execute(findtext:="[1-3]", Forward:=True) = True Then
                    '如果找到，则将其题号及数字选项插入excel文档
                    myWbook.ActiveSheet.Cells(n + 1, i).Value = Selection.Text
                Else
                    '如果该题没有选择（没有红色数字），则以选“不确定”计算
                    myWbook.ActiveSheet.Cells(n + 1, i).Value = 3
                End If
            End With
        Next i
        odoc.Close False
        ndoc = Dir()
    Loop
    myWbook.ActiveSheet.Range("a1:ag" & n + 1).HorizontalAlignment = xlCenter
    myWbook.ActiveSheet.Range("a1:ag" & n + 1).Borders.LineStyle = xlContinuous
    Set AppExcel = Nothing
    Application.ScreenUpdating = True
    MsgBox "共记录了" & n & "个文档的数据。", vbInformation
End Sub

dbzmc

程序运行出现"未定义类型"错误,错误之出为"AppExcel As Excel.Application",不知道什么原因

sylun

请在VBE“工具”菜单“引用”项中勾选对Microsoft Excel 对象库的引用再运行本过程。

dbzmc

谢谢，收到，完全好用！！