★调查问卷整理汇总应用实例详解（多工作簿汇总）

ljsandy

在实际工作中，我们经常会碰到信息的收集和整理，最近隔壁部门就碰到了回收后的调查问卷需要汇总到一张表中的问题，复制粘贴是简单，但实在效率太低，我看不下去，自告奋勇要用VBA来解决。第2天我给出了完成了的汇总表，着实让他们吃惊了一把。现在我将此代码分享给大家，也希望大家多提意见。

适用情况：
1。制作了一份调查问卷，需要员工（也可以是合作公司，下属单位，客户等等）在指定的单元格内进行填写；
2。需要将回收的问卷的内容进行整理，比如汇总到一张总表上，以便进行进一步的作图、分析、引用。

调查反馈.rar (22.86 KB, 下载次数: 1328)

2009-12-2 22:17 上传

点击文件名下载附件

附件说明：
1。调查问卷
    all_books[文件夹]，其中包含了a/b/c 3张问卷
2。对调查问卷的汇总
    调查结果汇总.xls（包含VBA代码，按RUN按钮运行）

注意：
1。调查问卷的文件中只有1个sheet，填写的内容必须在指定单元格内；
2。由于一开始就使用了列来记录数据，所以“调查结果汇总.xls”最多可以对253份问卷进行汇总。需要的话，可以对代码稍加改动，便可使用行来记录汇总结果，就可以汇总6万多条记录了。

参考资料：
现在一旦碰到了EXCEL上的问题，就会下意识的到EXCELHOME上搜索，通常都会找到自己满意的答案，真是非常感谢EXCELHOME的这个网站平台。在此呼吁大家在写求助贴之前先在站内搜索一下，一来搜索精度比较高，相对baidu找到答案的效率高多了；其次，大多数的情况下我们找不到完全符合自己需求的资源，但是类似的应用和解答还是很多的，这就需要求助者自己学会判断、比较、变通、修改，最终提高自己的EXCEL应用能力。我想这也是斑竹们所希望的。
感谢以下连接的LZ河山和解答高手zhaogang1960
http://club.excelhome.net/viewthread.php?tid=358020&highlight=%B6%E0%B9%A4%D7%F7%B2%BE%2B%BB%E3%D7%DC

[ 本帖最后由 ljsandy 于 2009-12-3 09:38 编辑 ]

ljsandy

Sub 汇总()
    Dim myPath$, myFile$, sht As Worksheet
    Dim wb As Workbook, th As Workbook    '定义详细的变量类型，可以提高代码的速度
    Dim arr, lr As Long, lr2 As Long             '声明变量,数组arr
    Dim x As Long
    Dim tempS(100) As String                  '声明数组变量
         
    Set th = ThisWorkbook
    myPath = ThisWorkbook.Path & "\all_books\"         '给路径变量赋值
    myFile = Dir(myPath & "\*.xls")               '用dir函数提取一个文件名
    Application.ScreenUpdating = False           '关闭屏幕刷新
    Application.DisplayAlerts = False            '禁用所有事件
   
    Range("d1:da50").ClearContents             '清除数据区内容，范围可以按需调整
   
    With ThisWorkbook.Sheets("Sheet1")            'with语句，下列最左边只有“.”的语句有共同的对象ThisWorkbook.Sheets("Sheet1")
        Do While myFile <> ""                     '当文件名不为空循环
        Workbooks.Open myPath & myFile            '打开all_books目录中的一个文件
        For Each sht In Sheets                    '对这个文件的每个工作表(这里假设每个文件的工作表数不定)
            

             lr2 = .Range("iv2").End(xlToLeft).Column + 1      '主工作表e列最后一个空单元格

            x = 1
            tempS(x) = sht.Range("e4").Value        '将问卷中指定单元格的内容附值到数组中
            x = x + 1
            tempS(x) = sht.Range("e6").Value
            x = x + 1
            tempS(x) = sht.Range("c9").Value
            x = x + 1
            tempS(x) = sht.Range("g9").Value
   
           'x = x + 1        '按调查表的格式，自己添加相应代码，最多100个内容，你也可以在Dim tempS(100) As String时多申请一点内存，比如temp(1000)                  
           'tempS(x) = sht.Range("XX").Value

            
          '下面进行写入汇总结果的操作
            x = 1
            For x = 1 To 4        '这里只用到了数组中的4个单元
                  th.Sheets(1).Cells(x, lr2) = tempS(x)
             Next
            
        Next                                     '继续循环打开文件的每个工作表，这里不会循环了，因为每个文件只有一张表
        ActiveWorkbook.Close                     '关闭打开的工作簿
        myFile = Dir                             '再用dir函数提取一个文件名
        Loop                                      '继续循环，重复上述过程
    End With
    Application.DisplayAlerts = True      '      启用所有事件
    Application.ScreenUpdating = True            '打开屏幕刷新
End Sub

[ 本帖最后由 ljsandy 于 2009-12-2 22:14 编辑 ]

cqr123

楼主，你是个标题党啊，东西呢

飞云楼主

辛苦了，谢谢。

menboy

留个标记

biggeneral

找清楚啊兄弟

兰家大妞

VBA不懂，正要学习。

leeking1672

看来要好好学习一下VBA了，不然完全看不懂的

jeffno1

非常感谢！学习了！！

bishunbiao

学习学习，现在正好在学小V