ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: OKJSJSF

[分享] Excel窗体控件练习(试卷界面)

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-21 22:56 | 显示全部楼层
不采用复制粘贴,改用移动的方法,被移动的工作簿关闭时不保存修改,可以得到单元格中超过255的全部字符
Sub move()
    Workbooks.Open Filename:=ThisWorkbook.Path & "\新建 Microsoft Excel 工作表 (2).xls"
    Sheets.move after:=ThisWorkbook.Sheets(Sheets.Count)
    ThisWorkbook.Close savechanges:=True
    Workbooks("新建 Microsoft Excel 工作表 (2).xls").Close False
End Sub
1、工作簿被打开,其中工作表才能被移动;
2、把全部工作表移动至代码工作簿的最后,如果被移动的工作表有部份隐藏的,后面二句代码不能调换顺序,否则程序会出错,不知为何?
3、先保存关闭代码所在工作簿,保存修改;
4、再不保存关闭被移出工作表的工作簿,不保存修改。
虽然Excel禁止隐藏全部工作表,却可以移动全部工作表。

补充内容 (2018-9-24 23:12):
”如果被移动的工作表有部份隐藏的“是指某些工作表隐藏,某些工作表显示。

TA的精华主题

TA的得分主题

发表于 2018-9-22 01:35 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-24 23:06 | 显示全部楼层
king5211 发表于 2018-9-22 01:35
谢谢分享,向楼主学习!

一次偶然使用才发现这单元格255的限制,复制与移动的区别!否则不知错到何时!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-9-30 22:28 | 显示全部楼层
本帖最后由 OKJSJSF 于 2018-9-30 22:30 编辑

请教各位朋友,如果把代码所在工作簿中的几张工作表格导出(采用移动的方法,不能用复制,也不用单元格区域赋值的办法)至新工作簿,关闭新工作簿(保存修改),代码所在工作簿不关闭(因为要继续操作它),如何让代码所在工作簿仍保留有原全部工作表,工作表不因移动而消失,代码该如何写?

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-3 17:29 | 显示全部楼层
本帖最后由 OKJSJSF 于 2018-10-3 18:28 编辑

为了克服前面所述单元格255个字符导入导出问题,对试卷程序中获取题库的代码作了修改《复制改移动》,程序能正常运行,但其中有我没能改进的错误,详见代码中的注释。希望得到朋友们帮助
Sub 获取题库()
    MsgBox Space(4) & "1、本程序仅支持2003版Excel工作簿题库。" & Chr(10) & Space(4) & "2、如果你的题库是压缩文件,请先解压她,然后直接把她移动或复制至本工作簿。" & Chr(10) & Space(4) & "3、如果题库工作簿中有禁止选中某表、禁止移动某表或工作簿保护等程序代码等,可以删除,防止程序冲突出错。" & Chr(10) & Space(4) & "4、如果题库工作簿中某工作表中某单元格中的内容长度超过255,采用鼠标右键在工作表标签处“复制”单表与多表工作组方法(勾选建立副本)将不能获取255个以上字符!" & Chr(10) & Space(4) & "所以需采用“移动”的方法(不勾选建立副本),或每张表分别操作。" & Chr(10) & Space(4) & "先在本试卷工作簿""勿删""表右边插入三张新工作表并命名,再激活题库工作簿全选某表(鼠标单击行号列标交叉处)复制,粘贴至新表(鼠标单击行号列标交叉处粘贴或选择A1单元格后按回车键)。" & Chr(10) & Space(4) & "5、如要使用新题库,你可删除已获取的旧题库,也可不。" & Chr(10) & Space(4) & "6、如新旧题库都有,待考试新题库表标签名必须修改为“判断、单选与多选”,三表不分顺序。", , "特别提醒:"
    ThisWorkbook.Unprotect
    Dim fil As String, wb As Workbook, sh As Worksheet, n As Byte
    fil = Application.GetOpenFilename(filefilter:="仅支持Excel2003版,*.xls", Title:="请选择题库文件", MultiSelect:=False)    '获取打开的文件名与路径
    If fil = "False" Then
        Exit Sub
    Else
        Application.ScreenUpdating = False
        Set wb = GetObject(fil)     '题库工作簿全称
        For Each sh In wb.Worksheets
            sh.Visible = 1      '隐藏的表格为什么必须在移动前就显示,移动后没法取消隐藏?但考试交卷后却能显示?
            If sh.AutoFilterMode = True Then sh.AutoFilterMode = False
        Next
        wb.Worksheets.Move After:=ThisWorkbook.Worksheets("勿删")     '移动全部表(包括隐藏的)至本工作簿第二
        For Each sh In ThisWorkbook.Worksheets
            ActiveWindow.ScrollRow = 1      '取消自动筛选后的表格的滚动条总是不能复位至最上方,原因何在?
            ActiveWindow.ScrollColumn = 1
            Cells(1).Select
        Next
        ThisWorkbook.Worksheets("勿删").Select
        On Error GoTo cancel
        wb.Close savechanges:=False     '采用移动方法后这句总会导致运行时自动化错误!原因何在?        
    End If
cancel: Application.ScreenUpdating = True        MsgBox "题库已导入本试卷程序所在工作簿。" & Chr(10) & "其中没用的工作表可以删除。"
        MsgBox "生成试卷的要求:" & Chr(10) & Space(4) & "1、题库题型包括判断题、单选题与多选题,分别保存在三个工作表中,工作表名称分别设为“判断、单选、多选”,各表第一行为列标题;" & Chr(10) & Space(4) & "2、判断题2个以上,各列内容至少依次为“序号、题干、答案”三列以上,答案值为“对、错 或 T、F”之一。" & Chr(10) & Space(4) & "3、单选题2个以上,各列内容至少依次为“序号、题干、选项A、B、C、D、答案”七列以上,其中选项为四列,答案值为“ABCD”中之一;" & Chr(10) & Space(4) & "4、多选题2个以上,各列内容至少依次为“序号、题干、选项A、B、C、D、E、答案”八列以上,其中选项为五列,答案值为“ABCDE”中之几;" & Chr(10) & Space(4) & "5、题库各表第 J 列将被用于存放考生答案,K 列将被用于存放考生答案与标准答案的比较结果;" & Chr(10) & Space(4) & "6、请务必先清除题库中多余的空行、空格、换行符、答案值中的奇异字符等。" & Chr(10) & Space(4) & "7、请在获取题库后即参照“勿删”表提示对题库“答案”、“列顺序”与“标签名称”等作检查处理。" & Chr(10) & Space(4) & "8、生成试卷前要自己确定试题个数、考试所需时间,每类题型至少考2个。"
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-3 18:36 | 显示全部楼层
查了下书,发现试卷获取题库的程序中,getopenfilename方法虽然取得文件全名,但实际并未打开题库工作簿,所以不存在关闭的问题!所以移动的程序存在问题!

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-3 20:34 | 显示全部楼层
但文件未打开,却可以移动,为什么?无力解决。

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-3 22:49 | 显示全部楼层
我越来越犯困了,原来wb.close savechanges:=false这句代码完全不需要,把其他工作簿的工作表移入代码所在工作簿时,移入后,工他工作簿的工作表并不会减少!工作簿不打开也可移动工作表!怪怪怪?滚动条无法滚动是由于窗口冻结!下一步要想办法如何定时禁用宏与恢复宏,如何删除工作簿中的VBA代码与对象等。修改后的试卷二版(固定选项可变题量) 试卷2版(固定选项 动态题量) .rar (35.04 KB, 下载次数: 42)
Sub 获取题库()
    MsgBox Space(4) & "1、本程序仅支持2003版Excel工作簿题库。" & Chr(10) & Space(4) & "2、如果你的题库是压缩文件,请先解压她,然后直接把她移动或复制至本工作簿。" & Chr(10) & Space(4) & "3、如果题库工作簿中有禁止选中某表、禁止移动某表或工作簿保护等程序代码等,可以删除,防止程序冲突出错。" & Chr(10) & Space(4) & "4、如果题库工作簿中某工作表中某单元格中的内容长度超过255,采用鼠标右键在工作表标签处“复制”单表与多表工作组方法(勾选建立副本)将不能获取255个以上字符!" & Chr(10) & Space(4) & "所以需采用“移动”的方法(不勾选建立副本),或每张表分别操作。" & Chr(10) & Space(4) & "先在本试卷工作簿""勿删""表右边插入三张新工作表并命名,再激活题库工作簿全选某表(鼠标单击行号列标交叉处)复制,粘贴至新表(鼠标单击行号列标交叉处粘贴或选择A1单元格后按回车键)。" & Chr(10) & Space(4) & "5、如要使用新题库,你可删除已获取的旧题库,也可不。" & Chr(10) & Space(4) & "6、如新旧题库都有,待考试新题库表标签名必须修改为“判断、单选与多选”,三表不分顺序。", , "特别提醒:"
    ThisWorkbook.Unprotect
    Dim fil As String, wb As Workbook, sh As Worksheet, n As Byte
    On Error GoTo cancel
'    Dim 某时 As Date
'    某时 = Now() + TimeValue("00:00:01")
'    Application.OnTime 某时, "启用宏"
'    Application.AutomationSecurity = msoAutomationSecurityForceDisable     '打开含代码的工作簿时禁用宏
    fil = Application.GetOpenFilename(filefilter:="仅支持Excel2003版,*.xls", Title:="请选择题库文件", MultiSelect:=False)    '获取打开的文件名与路径
    If fil = "False" Then
        Exit Sub
    Else
        Application.ScreenUpdating = False
        Set wb = GetObject(fil)     '题库工作簿全称
        For Each sh In wb.Worksheets
            sh.Visible = True      '隐藏的表格为什么必须在移动前就显示,移动后没法取消隐藏?但考试交卷后却能显示?
            If sh.AutoFilterMode = True Then sh.AutoFilterMode = False
        Next
        wb.Worksheets.Move After:=ThisWorkbook.Worksheets("勿删")     '移动全部工作表(包括隐藏的)至本工作簿某表之右
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name <> "勿删" Then
                sh.Select
                Range("C2").Select
                With ActiveWindow
                    .FreezePanes = False
                    .ScrollRow = 1
                    .ScrollColumn = 1
                    .FreezePanes = True
                End With
            End If
        Next
        ThisWorkbook.Worksheets("勿删").Select
        Application.ScreenUpdating = True
        MsgBox "题库已导入本试卷程序所在工作簿。" & Chr(10) & "其中没用的工作表可以删除。"
        MsgBox "生成试卷的要求:" & Chr(10) & Space(4) & "1、题库题型包括判断题、单选题与多选题,分别保存在三个工作表中,工作表名称分别设为“判断、单选、多选”,各表第一行为列标题;" & Chr(10) & Space(4) & "2、判断题2个以上,各列内容至少依次为“序号、题干、答案”三列以上,答案值为“对、错 或 T、F”之一。" & Chr(10) & Space(4) & "3、单选题2个以上,各列内容至少依次为“序号、题干、选项A、B、C、D、答案”七列以上,其中选项为四列,答案值为“ABCD”中之一;" & Chr(10) & Space(4) & "4、多选题2个以上,各列内容至少依次为“序号、题干、选项A、B、C、D、E、答案”八列以上,其中选项为五列,答案值为“ABCDE”中之几;" & Chr(10) & Space(4) & "5、题库各表第 J 列将被用于存放考生答案,K 列将被用于存放考生答案与标准答案的比较结果;" & Chr(10) & Space(4) & "6、请务必先清除题库中多余的空行、空格、换行符、答案值中的奇异字符等。" & Chr(10) & Space(4) & "7、请在获取题库后即参照“勿删”表提示对题库“答案”、“列顺序”与“标签名称”等作检查处理。" & Chr(10) & Space(4) & "8、生成试卷前要自己确定试题个数、考试所需时间,每类题型至少考2个。"
    End If
cancel:
End Sub

Sub 启用宏()
'    Application.AutomationSecurity = msoAutomationSecurityLow     '某时启用宏
End Sub

补充内容 (2018-10-7 20:59):
有需要的,请下载66楼的《试卷2版、初版、题库样式》压缩文件。此致

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-4 11:59 | 显示全部楼层
本帖最后由 OKJSJSF 于 2018-10-4 12:02 编辑

我的这种EXCEL试卷,在拖动滚动条时,计时会停止,所以相当于考试时间被不断延长!这个问题该如何解决?该添加另一套计时代码吧?

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-4 12:31 | 显示全部楼层
本帖最后由 OKJSJSF 于 2018-10-4 13:24 编辑

在拖动滚动条时,秒数累加程序被中止,停止拖动时继续恢复累加。计算机的当前时间应该是不因滚动条的拖动而中止的,所以,要取得试卷生成后的开始考试的当前计算机时间NOW1(),再显示实际计算机当前时间NOW2()与前个时间的差值NOW2()-NOW1(),供考生参考,时间到自动交卷。但,这个准确的考试时间到了,Ontime方法显示的累计时间还没到预设时间。所以不能用Ontime方法显示的累计时间,误导考生。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 21:36 , Processed in 0.049586 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表