搜索
人大经济论坛 附件下载

附件下载

所在主题:
文件名:  EXCEL电子问卷汇总.rar
资料下载链接地址: https://bbs.pinggu.org/a-491180.html
附件大小:
45.82 KB   举报本内容
由于许多用户宏是默认禁用的,这样会降低邮件发出去的EXCEL电子表格问卷的回收率,所以EXCEL电子表格问卷设计最好不带宏。
这样可以从另外一个表格进行汇总收集回来的多份表格。
为了符合自己的要求,大家可以对下面的附件进行修改,其注意事项为:
数据汇总表格和要汇总的表格放在同一文件夹内;
问卷内的表格控件链接设置到隐藏的SHEET2内的第三行,A3要空出来。

附件包含四个表格:
数据汇总.xls(内含VBA,一键汇总下面三个表格数据)
回收问卷1.xls
回收问卷2.xls
回收问卷3.xls

其VBA程序为:
Sub aa()
Dim Fso, Fld, Fln, Wk
Dim Wa As Workbook, W As Workbook
Dim Sh As Worksheet
Application.ScreenUpdating = False '关闭屏幕刷新
Application.DisplayAlerts = False '禁用所有事件
With ThisWorkbook.Sheets(1)
Range(.Cells(3, 1), .Cells(65536, 100)).ClearContents
End With
Set Wa = ThisWorkbook
Set Fso = CreateObject("Scripting.FilesystemObject")
Set Fld = Fso.getfolder(ActiveWorkbook.Path & "\")
Set Fln = Fld.Files
i = Wa.Sheets(2).[B65536].End(xlUp).Row
For Each Wk In Fln
If Wk.Name <> Wa.Name Then
Workbooks.Open Wk

Set W = ActiveWorkbook

W.Sheets(2).Rows(3).Copy
Wa.Sheets(1).Cells(i, 1).PasteSpecial Paste:=xlPasteValues
Wa.Sheets(1).Cells(i, 1) = W.Name
W.Close
i = i + 1
End If
Next
Application.DisplayAlerts = True ' 启用所有事件
Application.ScreenUpdating = True '打开屏幕刷新
End Sub


    熟悉论坛请点击新手指南
下载说明
1、论坛支持迅雷和网际快车等p2p多线程软件下载,请在上面选择下载通道单击右健下载即可。
2、论坛会定期自动批量更新下载地址,所以请不要浪费时间盗链论坛资源,盗链地址会很快失效。
3、本站为非盈利性质的学术交流网站,鼓励和保护原创作品,拒绝未经版权人许可的上传行为。本站如接到版权人发出的合格侵权通知,将积极的采取必要措施;同时,本站也将在技术手段和能力范围内,履行版权保护的注意义务。
(如有侵权,欢迎举报)
二维码

扫码加我 拉你入群

请注明:姓名-公司-职位

以便审核进群资格,未注明则拒绝

GMT+8, 2026-4-15 16:00