可用VBA

可用VBA 可用VBA 目录 TOC \o "1-3" \h \z \u 000．代码类别 4 1.调用数 4 2.Box 4 3.复制 4 4.清除 4 5.设置格式 4 001．打开网页 5 002．按需增加工作 5 003．清除系列 5 代码一：清除所有 5 代码二：清除部分 6 代码三：清除边框 6 代码4 6 代码5 7 代码6 7 代码7 8 004．按需删除行 8 005．删除空行 9 006．间隔填充（Box） 9 代码1（能直接应用） 10 代码2（不直接应用） 10 007．插入序号 11 代码1（有间隔） 11 代码2（无间隔） 11 代码3 11 008．复制工作表 13 009．超级复制（Box） 13 代码1（复制对象不受保护） 13 代码2（复制时自动解密） 14 代码3（复制时密码解密） 16 代码4（复制时密码解密恢复加密） 18 010．任意复制（Box） 20 011．提取工作表的名称 20 代码一：提取当前工作表名称 20 代码二：提取指定的工作表的名称 21 012．合并/打开工作簿 21 013．合并各工作表 22 014．成绩等级 25 015．求当月天数 26 代码1 26 代码2 26 016．返回最后一行数据的行（列）号 27 代码一：返回指定列最后非空单元格行号 27 代码二：矩形数据区域的最大行数 27 代码三：矩形数据区域的最大列数 27 代码四：矩形数据区域的最大列标 28 代码五：返回指定列最后一个非空单元格地址 28 代码六：矩形数据区域右下单元格绝对地址 28 代码七：选中矩形数据区域右下单元格 28 017．规范年月日 29 018．自动制作活动统计表 29 019．输入适时表名 31 020．BOX输入数据 32 021．创建列标 33 022．创建行标和列标（Box） 33 023．格式系列 34 1.列宽 34 2.加粗 34 3.居中 34 4.分散对齐 35 5.右对齐 35 6.自动换行 35 7.文本格式 35 8.添加边框 35 9.字体字号 37 10.缩小字体填充 37 11.内外边框 37 12.冻结窗格 38 024．表格综合设置 38 025．打印系列 42 1.打印标行 42 2.页边距 42 3.横向打印 42 026．添加边框与打印设置 42 1.添加固定表边框 42 2.添加活动表边框 43 3.打印设置 45 027．清除不定位数据区域 46 028．不定位数据跨表汇总 47 029．成绩汇总 48 030．求合格人数（率） 50 031．多条件查询移动数据 51 032．让合并单元格内的数据参与计算 52 033．小写金额转换为大写金额 53 034．公历日期转换为农历日期 54 代码1（年份为数字） 54 代码2（年份为汉字并带属相） 60 代码3（年份为汉字并带属相/201年） 67 END 73 000．代码类别 1.调用函数 2.Box 004间隔填充 007超级复制 008任意复制 3.复制 001复制B1:B12单元格的数据到C1:C12 006复制工作表 007超级复制 008任意复制 4.清除 003清除单元格 005插入序号 5.设置格式 （1）文本格式 017．格式系列 005插入序号 （2）居中 （3）分散对齐 （4）右对齐 （5）字体、字号 （6）加粗 （7）列宽 （8）合并单元格 001．打开网页 代码： Sub Command1_Click() 'VB连接http代码 Shell "explorer.exe http://shop.paipai.com/251822157" End Sub 说明： 1.使用该代码时，应将该代码复制到“模块”中。 2.该代码在“工具→宏→宏”对话框中“执行”。 3.代码中的“http://shop.paipai.com/251822157”为网页地址。 4.网页地址可根据需要进行修改。 002．按需增加工作表 代码： Sub Addsh_2() Dim i As Integer Dim sh As Worksheet For i = 4 To 20 Set sh = Sheets.Add(after:=Sheets(Sheets.Count)) sh.Name = i Next End Sub 代码解析： Addsh_2过程使用For...Next 语句和Add在工作簿中添加命名的17张工作表并将添加的工作表依次分别以“4、5、6……20”重命名。 在使用以上代码往工作簿中添加工作表时，如果工作簿中已存在相同名称的工作表，运行时会发生错误，代码中断。 003．清除系列 代码一：清除所有 Sub 清除所有() For s = 1 To 20 Sheets(s).Select '以上设置清除区域为第1-20个工作表. Cells.Select Selection.Clear '清除全部；如果只清除内容应将该行更改为“Selection.ClearContents” Next s End Sub 代码二：清除部分 Sub 清除部分() Range("B4:F13").Select '设置清除区域为“B3:F13”。 Selection.Clear '全部清除；如果只清除内容应将该行更改为“Selection.ClearContents” End Sub 代码三：清除边框 Sub 清除边框() Range("C5:E8").Select Selection.Borders(xlEdgeLeft).LineStyle = xlNone '清除左边框 Selection.Borders(xlEdgeTop).LineStyle = xlNone '清除上边框 Selection.Borders(xlEdgeBottom).LineStyle = xlNone '清除下边框 Selection.Borders(xlEdgeRight).LineStyle = xlNone '清除右边框 Selection.Borders(xlInsideVertical).LineStyle = xlNone '清除内纵边框 Selection.Borders(xlInsideHorizontal).LineStyle = xlNone '清除内横边框 End Sub 说明： 以上代码放在“模块”中“执行”。 代码4 在ThisWorkbook定位事件代码如下： Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)     If Target.Address = "$A$1" Then         Range("B3:C5").ClearContents     End If End Sub 含义4： 当激活某一单元格（如A1）后，另外指定的不相邻的单元格或单元格区域（如B3：C5和D7、F4等）中的数据同时消失成为空白单元格。 说明4： 该代码适用于代码所在的工作簿。 代码5 在相应的Sheet中定位事件代码如下： Private Sub Worksheet_SelectionChange(ByVal Target As Range)     If Target.AddressLocal = Range("A1").AddressLocal Then            '如果激活单元格是A1         Range("B3:C5").ClearContents                                                  '清除B3：C5区域内容。     End If End Sub 含义5： 当激活某一单元格（如A1）后，另外指定的不相邻的单元格或单元格区域（如B3：C5和D7、F4等）中的数据同时消失成为空白单元格。 说明5： 该代码适用于代码所在的工作表。 代码6 在相应的Sheet中定位事件代码如下： Private Sub Worksheet_Change(ByVal Target As Range)     If Target.AddressLocal = Range("B2").AddressLocal And Val(Target.Text) <> 2008 Then         Range("B3:C5").ClearContents                                        '当B2单元格改变后并且值不是2008时，清空B3:C5区域内容。     End If End Sub 含义6： 如果某一单元格的设定值为2008，但输入值却不等于2008时，另外的指定单元格或单元格区域中的数据消失成为空白单元格。 说明6： 1．要测试的话，不要放在模块中，因为代码要响应Sheet的Change和SelectionChange事件，所以应该放在Sheet中,比如Sheet1，Sheet2等。 2．“公式二”中的“2008”如果要改变为适时年份只需将“2008”改为取年份的代码“Year（Date）”即可。 3．该代码适用于代码所在的工作表。 代码7 Sub ClearSheet() Worksheets("Sheet1").Cells.ClearContents End Sub 功能： 清除活动工作簿中 Sheet1 上的所有单元格的内容。 说明： 该代码放在“模块”中“执行”。 004．按需删除行 Sub 删除行() '选定区域如无数据,则运行时报错 '关闭屏幕刷新，使程序运行更快 Application.ScreenUpdating = False '开始选择操作区域(这2行代码根据"汇总"修改) S = InputBox("目标数据区工作表", , "") Sheets(S).Select h = Application.WorksheetFunction.Max(Range("a1:a96")) + 7 Range(Cells(h, 1), Cells(96, 1)).Select '删除行 Selection.EntireRow.Delete '打开屏幕刷新 Application.ScreenUpdating = True End Sub 功能： 删除所选工作表中的所选行。 说明： 该代码放在“模块”中“执行”。 005．删除空行 如果需要删除工作表中所有的空行，可以使用下面的代码。 Sub 删除空行() Dim rRow As Long Dim LRow As Long Dim i As Long rRow = Sheet1.UsedRange.Row LRow = rRow + Sheet1.UsedRange.Rows.Count - 1 For i = LRow To rRow Step -1 If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).Delete End If Next End Sub 代码解析： DelBlankRow过程删除工作表中已使用的区域的所有空行。 第5行代码获得工作表中已使用区域的首行行号，其中使用UsedRange属性返回工作表中已使用的区域。 第6行代码获得工作表中已使用区域的最后一行行号。 第7行到第11行代码从最大行数至最小行数循环判断指定行是否为空行，若为空行则删除该行。 注意 此处一定要从最大行数至最小行数开始循环判断，因为如果工作表中存在两行及两行以上的相邻空行，从最小行数开始循环删除的话，当第一行空行被删除后，被删除行下面的一行会往上移位，而此时For...Next循环的计数器已经加1，所以会出现漏删除的现象。 其中第8、9行代码使用工作表CountA函数判断当前行已使用单元格的数量，如果为零说明此行是空行则使用Delete删除。 应用于Range对象的Delete方法删除对象，语法如下： expression.Delete(Shift) 参数expression是必需的，返回一个Range对象。 参数Shift是可选的，指定删除单元格时替补单元格的移位方式。可为以下 XlDeleteShiftDirection常量之一：xlShiftToLeft或xlShiftUp。如果省略该参数，则Microsoft Excel将根据区域的图形决定移位方式。 说明： 该代码放在“模块”中“执行”。 006．间隔填充（Box） 功能： 对如“间隔填充”图中的B2：B6、B8：B9、B11：B15进行间隔填充至效果如B列中的B2：B15。 代码1（能直接应用） Sub 填充() Dim k As Range Set k = Application.InputBox("请选择要操作的单元格区域：", "选择单元格", Type:=8) If k.Count > [a65536].End(xlUp).Row Then Range(Split(k.Address(0, 0), ":")(1)) = Cells([a65536].End(xlUp).Row, 1) k.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" Set k = Nothing End Sub 代码2（不直接应用） Sub 间隔填充() Dim k As Range Set k = Application.InputBox("请选择要操作的单元格区域：", "选择单元格", Type:=8) If k Is Nothing Then Exit Sub k.SpecialCells(xlCellTypeBlanks).Select Selection.FormulaR1C1 = "=R[-1]C" Set k = Nothing End Sub 说明： 1.两段代码均放在“模块”中“执行”。 2.应用“代码2”时，应在执行该代码前先将最后一个数据在复制区域的最后一个单元格内编辑出来。 007．插入序号 功能： 给B列中的数据在A列添加对应的四位数序号。 代码1（有间隔） Sub 插入序号() Application.ScreenUpdating = False '关闭屏幕刷新，使程序运行更快 Range("a3:a65536").ClearContents '清除A3至A65536区域的数据 Columns(1).NumberFormat = "@" '设置A列为文本格式 For i = 3 To [b65536].End(xlUp).Row '循环开始 If Cells(i, 2) <> "" Then '判断第2列的每个单元格是否为空 Cells(i, 2).Offset(0, -1) = Format(i - 2, "0000") '不足四位前补0，然后把它写到对应单元格的左边单元格 End If '结束IF语句' Next '循环结束点 Application.ScreenUpdating = True '打开屏幕刷新 End Sub 代码2（无间隔） Sub 插入序号() Application.ScreenUpdating = False '关闭屏幕刷新，使程序运行更快 Range("a3:a65536").ClearContents '清除A3至A65536区域的数据 Columns(1).NumberFormat = "@" '设置A列为文本格式 For i = 3 To [b65536].End(xlUp).Row '循环开始 If Cells(i, 2) <> "" Then '判断第2列的每个单元格是否为空 k = k + 1 Cells(i, 2).Offset(0, -1) = Format(k, "0000") '不足四位前补0，然后把它写到对应单元格的左边1格（“-1”）单元格 End If '结束IF语句' Next '循环结束点 Application.ScreenUpdating = True '打开屏幕刷新 End Sub 代码3 Sub 插入序号() Application.ScreenUpdating = False '关闭屏幕刷新，使程序运行更快 Range("a3:a65536").ClearContents '清除A3至A65536区域的数据 Columns(1).NumberFormat = "@" '设置A列为文本格式 For i = 3 To [b65536].End(xlUp).Row '循环开始 If Cells(i, 2) <> "" Then '判断第2列的每个单元格是否为空 For k = 1 To Len(Cells(i, 2)) '这里不是直接从第二位开始取序号而是设置一个循环，其好处是无论前面有几个字母都能保证取得序号的准确 If IsNumeric(Mid(Cells(i, 2), k, 1)) Then '判断取得的值是否是数字 Cells(i, 2).Offset(0, -1) = Format(Mid(Cells(i, 2), k), "0000") '若是数字就从当前位开始一直取到最后且不足四位前补0，然后把它写到对应单元格的左边单元格 Exit For '退出循环 End If '结束IF语句 Next '循环结束点 End If '结束IF语句' Next '循环结束点 Application.ScreenUpdating = True '打开屏幕刷新 End Sub 说明： 1.用“Range("a3:a65536").ClearContents”清除A3至A65536区域的数据，是因为序号将插入到A3︰A65536区域。所以可根据序号插入的区域对其中的“a3:a65536”进行更改。 2.用“Columns(1).NumberFormat = "@"”设置第“1”列即A列为文本格式，是因为有些序号的前面可能有“0”。所以可根据序号插入的区域所在列的列标对其中的“Columns(1)”进行更改。 3.用“For i = 3 To [b65536].End(xlUp).Row”建立数据的行的循环，是因为A列的序号要依据B列（即“[b65536]”）的第“3”行起的那些数据来插入。所以可根据插入序号时要依据的数据所在区域的起始行行号和列标对其中的“3 To [b65536]”进行更改。 4.用“If Cells(i, 2) <> "" Then”判断第2列的每个单元格是否为空，是因为A列的序号要依据第2列的每个单元格（即“Cells(i, 2)”）的那些数据来插入。所以可根据插入序号时要依据的数据所在区域的列标对“Cells(i, 2)”中的“2”进行更改。 5.用“Cells(i, 2).Offset(0, -1) = Format(i - 2, "0000")”将第2列的每个单元格（即“Cells(i, 2)”）中的数据对应的序号分别写到同一行的左边1列的单元格（即“Offset(0, -1)”）中，其中用“Format(i - 2, "0000")”中的“i – 2”根据数据所在的行号来计算这个数据的序号值，“"0000"”指序号值应是四位数，不足四位的在前补0。所以，除了可根据插入序号时要依据的数据所在区域的列标对“Cells(i, 2)”中的“2”进行更改外，还可根据插入的序号相对于原数据的位置对“Offset(0, -1)”中的“0” （表示行号相差为0）和“-1”（表示左边1列）进行更改；另外，“i – 2”中的“2”指的是标题行和字段行共2行,可酌情更改；如果序号值不是四位数，不足数位也不想在前补0，可对“"0000"”酌情更改。 6. 如果你要的不管是不是有空单元格，序号都连续，应用代码2，其实就是把代码1再引入一个变量就好了，即在代码1的第6行与第7行之间加一行“K=K+1”，并把“Format(i-2, "0000")”改为“ Format(k, "0000") ”就好了，这样序号就是连续的了。 7.“代码3”的作用相当于提取单元格数据中的数值，因此，在添加序号方面无甚意义。 8. 三段代码均放在“模块”中“执行”。 008．复制工作表 功能： 将一个工作表中的数据复制到结构相同的另一个工作表中。 代码： Sub 复制() b = Sheets(2).[a1].CurrentRegion.Rows.Count + 1 '判断表2的行数 For i = 2 To b '复制的数据从第2行起.如果复制的数据不是从第2行起,可将"2"作相应的修改. a = Sheets(1).[a1].CurrentRegion.Rows.Count + 1 '判断表1的行数 c = Sheets(2).[a1].CurrentRegion.Columns.Count '判断表2的列数 If Application.WorksheetFunction.CountIf(Sheets(1).[b1:b1000], Sheets(2).Cells(i, 2)) <> 10 Then '如果只复制不重复的数据,应将"<>10"改为"=0" Sheets(2).Range(Sheets(2).Cells(i, 1), Sheets(2).Cells(i, c)).Copy Sheets(1).Cells(a, 1) '将表2中的数据从第1列(Cells(i,1))起至第c列(Cells(i,c))复制到表1中的第1列(Cells(a,1))起至同样的列数.如果复制的不是从第1列起或者也不是至第c列止,可对列标作相应的修改. End If Next End Sub 说明： 1.该代码放在“模块”中“执行”。 2.可通过移动工作表标签的方法灵活地使各工作表成为代码中的“Sheet1（表1）”和“Sheet2（表2）”；也可修改代码“Sheets(1)”、“ Sheets(2)”中的“1”、“2”。 009．超级复制（Box） 功能： 将结构相同的许多工作表中的数据复制到同一个结构相同的工作表中。 代码1（复制对象不受保护） Sub 超级复制() Dim k As Range, intRow% '调用单元格区域选择框，可以用鼠标直接在工作表上点选 Set k = Application.InputBox("请选择要复制的数据所在工作表的“A1”单元格：", "选择复制对象:", Type:=8) '没有选择单元格则退出 If k Is Nothing Then Exit Sub '关闭屏幕刷新 Application.ScreenUpdating = False With ActiveSheet '定位当前工作表的可用空行 intRow = ActiveSheet.[A65536].End(xlUp).Row + 1 '将选择的工作表的数据内容复制到当前工作表，依次往下填入 k.CurrentRegion.Copy Destination:=ActiveSheet.Cells(intRow, 1) '删除复制过来的数据的标题行 .Rows(intRow).Delete .Rows(intRow).Delete ''''''只增加了这一句就行，之前删除了标题，字段这行就成了Rows(intRow)，再次删除即可 End With '打开屏幕刷新 Application.ScreenUpdating = True '释放占用的内存 Set k = Nothing End Sub 说明： 1.该代码放在“模块”中“执行”。 2.该代码中如果只有1行“.Rows(intRow).Delete”，适用于被复制工作表的表头为1行（只有“标题”行或者只有“字段名”）的工作表；如果有2行“.Rows(intRow).Delete”，则适用于被复制工作表的表头为2行（第一行为“标题”行，第二行为“字段名”——两行均有文字。）的工作表；如果有3行“.Rows(intRow).Delete”，则适用于被复制工作表的表头为3行（第一行为“标题”行，第二行为副标题，第三行为“字段名”——三行均有文字。）的工作表；……以此类推。但必须是表头各行（即从“标题”行到“字段名”所在行）均不为空。 3.如果从“标题”行到“字段名”所在行的各行之中有空行，代码中的“.Rows(intRow).Delete”行数另行确定。 代码2（复制时自动解密） '---------Add 2010/11/20 加入两个变量记录两个sheet名--------- Dim Des As String '目标sheet的sheet名 Dim Sou As String '源数据的sheet名 '+++++++++Add 2010/11/20 加入两个变量记录两个sheet名+++++++++ Sub 超级复制() Dim k As Range, intRow% '调用单元格区域选择框，可以用鼠标直接在工作表上点选 Set k = Application.InputBox("请选择要复制的数据所在工作表的“A1”单元格：", "选择复制对象:", Type:=8) '没有选择单元格则退出 If k Is Nothing Then Exit Sub '关闭屏幕刷新 Application.ScreenUpdating = False With ActiveSheet '---------Add 2010/11/20 Des等于目标sheet名--------- Des = ActiveSheet.Name '+++++++++Add 2010/11/20 Des等于目标sheet名+++++++++ '定位当前工作表的可用空行 intRow = ActiveSheet.[A65536].End(xlUp).Row + 1 '将选择的工作表的数据内容复制到当前工作表，依次往下填入 '---------Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程--------- Sou = k.Worksheet.Name Call UNPROTECTSHEET '由于有的sheet会有密码保护，所以使用UNPROTECTSHEET过程破解该sheet的密码 '+++++++++Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程+++++++++ Sheets(Des).Select k.CurrentRegion.Copy 'MsgBox k.Worksheet.Name ActiveSheet.Cells(intRow, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '删除复制过来的数据的标题行 .Rows(intRow).Delete .Rows(intRow).Delete ''''''只增加了这一句就行，之前删除了标题，字段这行就成了Rows(intRow)，再次删除即可 End With '打开屏幕刷新 Application.ScreenUpdating = True '释放占用的内存 Set k = Nothing End Sub '---------Add 2010/11/20 密码破解过程--------- Sub UNPROTECTSHEET() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next If Sheets(Sou).ProtectContents = False Then MsgBox "NO" Exit Sub End If For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 Sheets(Sou).Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If Sheets(Sou).ProtectContents = False Then MsgBox Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: Next: End Sub '+++++++++Add 2010/11/20 密码破解过程+++++++++ 说明： 1.该代码放在“模块”中“执行”。 2.执行该代码能自动给受保护的数据解密后进行复制，但无法自动恢复对数据的保护。 代码3（复制时密码解密） '---------Add 2010/11/20 加入两个变量记录两个sheet名--------- Dim Des As String '目标sheet的sheet名 Dim Sou As String '源数据的sheet名 '+++++++++Add 2010/11/20 加入两个变量记录两个sheet名+++++++++ Sub 超级复制() Dim k As Range, intRow% '调用单元格区域选择框，可以用鼠标直接在工作表上点选 Set k = Application.InputBox("请选择要复制的数据所在工作表的“A1”单元格：", "选择复制对象:", Type:=8) '没有选择单元格则退出 If k Is Nothing Then Exit Sub '关闭屏幕刷新 Application.ScreenUpdating = False With ActiveSheet '---------Add 2010/11/20 Des等于目标sheet名--------- Des = ActiveSheet.Name '+++++++++Add 2010/11/20 Des等于目标sheet名+++++++++ '定位当前工作表的可用空行 intRow = ActiveSheet.[A65536].End(xlUp).Row + 1 '将选择的工作表的数据内容复制到当前工作表，依次往下填入 '---------Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程--------- Sou = k.Worksheet.Name Call UNPROTECTSHEET '由于有的sheet会有密码保护，所以使用UNPROTECTSHEET过程破解该sheet的密码 '+++++++++Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程+++++++++ Sheets(Des).Select k.CurrentRegion.Copy 'MsgBox k.Worksheet.Name ActiveSheet.Cells(intRow, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '删除复制过来的数据的标题行 .Rows(intRow).Delete .Rows(intRow).Delete ''''''只增加了这一句就行，之前删除了标题，字段这行就成了Rows(intRow)，再次删除即可 End With '打开屏幕刷新 Application.ScreenUpdating = True '释放占用的内存 Set k = Nothing End Sub '---------Add 2010/11/20 密码破解过程--------- Sub UNPROTECTSHEET() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next If Sheets(Sou).ProtectContents = False Then 'MsgBox "NO" Exit Sub End If Dim Pwd As String L1: Pwd = Application.InputBox("请输入工作表密码", "提示", Type:=2) Sheets(Sou).Unprotect Pwd If Sheets(Sou).ProtectContents = True Then MsgBox "密码填写错误,请重新填写" GoTo L1 Else Exit Sub End If End Sub '+++++++++Add 2010/11/20 密码破解过程+++++++++ 说明： 1.该代码放在“模块”中“执行”。 2.执行该代码输入密码给受保护的数据解密后进行复制，无法自动恢复对数据的保护。 代码4（复制时密码解密恢复加密） '---------Add 2010/11/20 加入两个变量记录两个sheet名--------- Dim Des As String '目标sheet的sheet名 Dim Sou As String '源数据的sheet名 Dim Pwd As String Dim isProtected As Boolean '+++++++++Add 2010/11/20 加入两个变量记录两个sheet名+++++++++ Sub 超级复制() Dim k As Range, intRow% '调用单元格区域选择框，可以用鼠标直接在工作表上点选 Set k = Application.InputBox("请选择要复制的数据所在工作表的“A1”单元格：", "选择复制对象:", Type:=8) '没有选择单元格则退出 If k Is Nothing Then Exit Sub '关闭屏幕刷新 Application.ScreenUpdating = False With ActiveSheet '---------Add 2010/11/20 Des等于目标sheet名--------- Des = ActiveSheet.Name '+++++++++Add 2010/11/20 Des等于目标sheet名+++++++++ '定位当前工作表的可用空行 intRow = ActiveSheet.[A65536].End(xlUp).Row + 1 '将选择的工作表的数据内容复制到当前工作表，依次往下填入 '---------Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程--------- Sou = k.Worksheet.Name Call UNPROTECTSHEET '由于有的sheet会有密码保护，所以使用UNPROTECTSHEET过程破解该sheet的密码 '+++++++++Add 2010/11/20 Sou等于源sheet名 并调用密码破解过程+++++++++ Sheets(Des).Select k.CurrentRegion.Copy 'MsgBox k.Worksheet.Name ActiveSheet.Cells(intRow, 1).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False '删除复制过来的数据的标题行 .Rows(intRow).Delete .Rows(intRow).Delete ''''''只增加了这一句就行，之前删除了标题，字段这行就成了Rows(intRow)，再次删除即可 End With Call PROTECTSHEET '重新加密 '打开屏幕刷新 Application.ScreenUpdating = True '释放占用的内存 Set k = Nothing End Sub '---------Add 2010/11/20 密码破解过程--------- Sub UNPROTECTSHEET() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next If Sheets(Sou).ProtectContents = False Then isProtected = False Exit Sub End If L1: Pwd = Application.InputBox("请输入工作表密码", "提示", Type:=2) Sheets(Sou).Unprotect Pwd isProtected = True If Sheets(Sou).ProtectContents = True Then MsgBox "密码填写错误,请重新填写" GoTo L1 Else Exit Sub End If End Sub '+++++++++Add 2010/11/20 密码破解过程+++++++++ '---------Add 2010/11/22 重新加密过程--------- Sub PROTECTSHEET() If Sheets(Sou).ProtectContents = False And isProtected = True Then Sheets(Sou).Protect Pwd End If End Sub '+++++++++Add 2010/11/22 重新加密过程+++++++++ 说明： 1.该代码放在“模块”中“执行”。 2.执行该代码输入密码给受保护的数据解密后进行复制，并且自动恢复对数据的保护。 010．任意复制（Box） 功能： 复制操作时，复制区域的位置和大小以及粘贴区域的位置都可以在执行代码的过程中任意选择，且不受加密数据的影响。 代码： Sub 任意复制 () Sheets("003").Select S1 = InputBox("源数据区起点单元格", , "A2") ‘代码中的源数据区起点单元格名称可酌情更改，也可只填写列标或者空着。 S2 = InputBox("源数据区终点单元格", , "D10") ‘代码中的源数据区终点单元格名称可酌情更改，一般只填写列标，也可空着。 S = S1 & ":" & S2 S3 = InputBox("目标数据区工作表", , "") Range(S).Select Selection.Copy Sheets(S3).Select S4 = InputBox("目标数据区起点单元格", , "A4") ‘代码中的目标数据区起点单元格名称可酌情更改，也可只填写列标或者空着。 Range(S4).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End Sub 说明： 1.该代码放在“模块”中“执行”。 2.运行代码过程中，源数据区终点单元格名称一定要准确输入，千万不得有误！否则会让其他代码运行时把多出的空白区域当作数据区域。 3.附：在sheet里单击任意一个有文字的单元格，然后按下“Ctrl + A”键，阴影显示的是现有工作区内有数据的所有单元格(有阴影的空白区域也被认定有数据)。 011．提取工作表的名称 代码一：提取当前工作表名称 Sub 返回当前工作表名称() wsName = ActiveSheet.Name MsgBox "当前工作表为：" & wsName '如果不想以对话框的形式显示结果,这一行查更改为“range("单元格名称") = wsName” End Sub 代码二：提取指定的工作表的名称 Function TiQuBM(x As Integer) If x = 0 Then TiQuBM = ActiveCell.Parent.Name ElseIf x > 0 And x <= Sheets.Count Then TiQuBM = Sheets(x).Name ElseIf x > Sheets.Count Then MsgBox "超出范围" End If Application.Volatile End Function 该函数使用方法： 取当前工作表名称 =Intsheet(0) 取第N个工作表名称 =Intsheet(N) N为正整数 012．合并/打开工作簿 Sub 合并或打开工作簿() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="要合并的文件") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "没有选中文件" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '只需删去“.Count”后即可打开需要的工作簿 x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub 013．合并各工作表内容 该代码先创建一个新工作表作为第一个工作表，然后将同一工作簿中的各工作表的内容复制到这个新的工作表中。 Sub 合并各工作表内容() sp = InputBox("各表内容之间，间隔几行？不输则默认为0") If sp = "" Then sp = 0 End If st = InputBox("各表从第几行开始合并？不输则默认为2") If st = "" Then st = 2 End If Sheets(1).Select Sheets.Add '增加新工作表Sheet1为第一个工作表 If st > 1 Then Sheets(2).Select Rows("1:" & CStr(st - 1)).Select Selection.Copy Sheets(1).Select Range("A1").Select ActiveSheet.Paste y = st - 1 End If For i = 2 To Sheets.Count Sheets(i).Select For v = 1 To 256 zd = Cells(65535, v).End(xlUp).Row If zd > x Then x = zd End If Next v If y + x - st + 1 + sp > 65536 Then MsgBox "内容太多，仅合并前" & i - 2 & "个表的内容，请把其它表复制到新工作薄里再用此程序合并！" Else: Rows(st & ":" & x).Select Selection.Copy Sheets(1).Select Range("A" & CStr(y + 1)).Select ActiveSheet.Paste Sheets(i).Select Range("A1").Select '取消单元格被全选状态。 Application.CutCopyMode = False '忘掉复制的内容。 End If y = y + x - st + 1 + sp x = 0 Next i Sheets(1).Select Range("A1").Select '光标移至A1。 MsgBox "这就是合并后的表，请命名！" End Sub 014．成绩等级 用户在Excel中可以自定义函数。切换至 Visual Basic模块，或插入一页新的模块表（Module），在出现的空白程序窗口中键入自定义函数VBA程序，按Enter确认后完成编写工作，Excel将自动检查其正确性。此后，在同一工作薄内，你就可以与使用Exed内部函数一样在工作表中使用自定义函数，如： Function Dengji(a) If a＜ 60 Then Dengji＝“不及格” Else Dengji=“及格” End If End Function 以上公式应该变更为： Function Dengji(a) '自编 If a >= 60 Then Dengji = "及格" If a < 60 Then Dengji = "不及格" End Function 进一步变更为计算“满分”、“优秀”、“及格”、“不及格”4个等级的公式： Function Dengji(a) '自编 If a > 100 Or a < 0 Then Dengji = "数据错误" If a = 100 Then Dengji = "满分" If a >= 80 And a < 100 Then Dengji = "优秀" If a >= 60 And a < 80 Then Dengji = "及格" If a < 60 And a >= 0 Then Dengji = "不及格" If a = "" Then Dengji = "" End Function 该公式的意思是：如果数据大于100或者小于0，那么公式的结果