《通过实例来学习VBA代码》 数据的复制 ★从其他工作表里复制数据 Sub 复制() Sheet1.Range("A1:I40").Value = ThisWorkbook.Path \ [1.xls].Sheet1.Range("A1:I40").Value End Sub ★批量复制 Sub 复制() For i = 1 To 12 Range("C" & i) = Range("B" & i) Next i End Sub ★数据叠加 Sub累计() If (vbOK = MsgBox("数据汇总?", vbOKCancel)) Then Dim b As Long For b = 11 To 42 Range("J" & b) = Range("J" & b) + Range("I" & b) Next b End If End Sub ★ 复制对话框的值 Private Sub CommandButton1_Click() Dim i As Integer a = .Range("A65536").End(3).Row + 1 For I = 1 To 9 Cells(a, I) = Val(Me.Controls("TextBox" & I)) Next I Unload Me End Sub 设置工作表密码 ActiveSheet.Protect Password:=888888 ' 保护工作表并设置密码 ActiveSheet.Unprotect Password:=888888 '撤消工作表保护并取消密码 打印设置 ★对部分区域进行打印 Sub 打印表格() MsgBox "现在打印<其他应收款>和<其他应付款>" ActiveSheet.PageSetup.PrintArea = "B2:E36" '设置打印区域 ActiveWindow.SelectedSheets.PrintOut From:=1, To:=3, Copies:=1, Collate:=True MsgBox "现在打印<预收账款>和<应缴税金>" ActiveSheet.PageSetup.PrintArea = "B39:E74" ActiveWindow.SelectedSheets.PrintOut From:=1, To:=3, Copies:=1, Collate:=True ActiveSheet.PageSetup.PrintArea = "" '取消打印区域的设置" MsgBox "打印完毕!" End Sub ★进入打印预览 Sub 打印预览() ActiveWindow.SelectedSheets.PrintPreview End Sub ★ 直接打印 Sub 直接打印() ActiveWindow.SelectedSheets .PrintOut From:=1, To:=3, Copies:=1, Collate:=True End Sub 自动运行 ★ 打开工作薄自动运行:Private Sub Workbook_Open() ★ 关闭工作薄自动运行:Private Sub Workbook_BeforeClose(Cancel As Boolean) ★ 打开对话框自动运行:Private Sub UserForm_Initialize() ★ 工作表激活后执行:Private Sub Worksheet_Activate() ■条件退出程序代码的基本形式If [ ] = "" Then MsgBox ("没有数据"): Exit Sub ■执行代码前询问形式:If (vbOK = MsgBox("是否执行操作?", vbOKCancel)) Then 加快速度 Application.ScreenUpdating = False '关闭屏幕刷新 Application.Calculation = xlCalculationManual '手动重算 Application.Calculation = xlCalculationAutomatic '自动重算 Application.ScreenUpdating = True '打开屏幕刷新 逐行输入 ★ 逐行录入(一) Sub 产品入库() Q = Range("C65536").End(3).Row + 1 Range("C" & Q & ":I" & Q).Value = Range("C20:I20").Value End Sub ★ 逐行录入(二) 领会For的用法:基本形式for…to….next Sub 产品入库() If Range("C1") > 59 Then Exit Sub '当数据录入超过59行,停止运行本程序 Dim a As Long Dim b As Integer a = Range("C1") For b = 1 To 9 Cells(a + 11, b).Value = Cells(7, b).Value Next b End Sub 分析: 单元格的Cells表达方式,它的坐标是(行,列)显示的,如:Cells(7, 1)是指A7 ★逐行录入(三) Sub 记帐() If [H3] = "" Then MsgBox ("请填写单位名称"): Exit Sub A = [D3] '复制源坐标 B = [D4] '黏贴点坐标 C = Sheet11.Range(A) Sheet2.Range(B) = C End Sub 分析:A,B是两个单元格区域坐标,首先在任意的单元格里用函数定义坐标,分别代表数据复制源和黏贴点。然后将坐标结合在相应的工作表名称上,通过C来复制。 利用Find查找和修改 Private Sub CommandButton1_Click() '查询按钮 Dim SS As Range Dim I As Integer Set SS = Sheet1.Range("A2", Range("A65536").End(3)).Find(TextBox10.Value) If Not SS Is Nothing Then For I = 1 To 9 Me.Controls("TEXTBOX" & I) = Cells(SS.Row, I + 1) Next I CommandButton2.Visible = True CommandButton1.Visible = False Else MsgBox "没有找到!" & TextBox10 End If End Sub **************** Private Sub CommandButton2_Click() '修改按钮 Dim SS As Range Dim I As Integer Set SS = Sheet1.Range("A2", Range("A65536").End(3)).Find(TextBox10.Value) If Not SS Is Nothing Then For I = 1 To 9 Cells(SS.Row, I + 1) = Val(Me.Controls("TEXTBOX" & I)) Next I For I = 1 To 9 Me.Controls("TEXTBOX" & I) = "" Next I CommandButton1.Visible = True CommandButton2.Visible = False End If End Sub ★用Like方法查找 在A1:A10的范围里查找包含数字5的单元格,并设置成红色。 Sub test() Dim Cell As Range For Each Cell In [A1:A10] If Cell Like "*5*" Then Cell.Interior.ColorIndex = 3 End If Next End Sub ★行的增加和删除 Sub 增加行一() If Range("M2") > 30 Then Exit Sub A = Range("a:a").Find("合计").Row - 1 '寻找“合计”所在行-1 Rows(A).Copy '复制 Rows(A).Insert Shift:=xlDown '方向向下移动 Application.CutCopyMode = False End Sub Sub 删除行() If Range("M2") < 13 Then Exit Sub B = Range("a:a").Find("合计").Row - 1 '寻找“合计”所在行-1 Rows(B).Delete Shift:=3 '方向向上移动 End Sub 分析:1.该示例设定了增加、删除行的限定范围。 2.利用查找某行数值(“合计”)来定位复制或删除的行数。 Sub 增加行二() On Error Resume Next '忽略错误 Dim r As Long '设置变量r r = ActiveCell.Row '将r定义为地前鼠标所在行 If r > 3 Then '如果行数大于3执行命令 Rows(r).Insert Shift:=xlDown '所在行向下移动 End If End Sub Change的运用 ★ 在对话框里A输入数字,对话框B同步显示数字中文大写 Private Sub TextBox3_Change() [I7] = Val(TextBox3) TextBox4.Value = [D7] End Sub 分析:首先将textbox3的值赋予“I7”单元格 单元格“D7”的内容是中文转换公式 将“D7”的值赋予textbox4 ★弹出对话框的条件 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row > 1 Then If Target.Column = 4 Or Target.Column = 5 Then UserForm1.Show End If End If End Sub ★对话框之间建立勾稽关系 Private Sub TextBox1_Change() TextBox3.Value = Val(TextBox1) + Val(TextBox2) End Sub Private Sub TextBox2_Change() TextBox3.Value = Val(TextBox1) + Val(TextBox2) End Sub 分析:也可以用textbox1*1+textbox2*1表示 ★当单元格发生变化时执行程序: Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub '自动添加序号 If Target.Column = 2 And Target.Row >= 4 Then Target.Offset(0, -1) = Target.Row - 3 End If S= [A65536].End(3).Row Range("A3:F" & S ).Borders.LineStyle = 2 End Sub 按钮的激活切换 ★冻结“确认”按钮(当两个对话框都有数据时恢复) Sub ComboBox1_Change() CommandButton1.Enabled = (ComboBox1 <> "" And TextBox1 <> "") End Sub Sub TextBox1_Change() CommandButton1.Enabled = (ComboBox1 <> "" And TextBox1 <> "") End Sub Private Sub UserForm_Initialize() CommandButton1.Enabled = (ComboBox1 <> "" And TextBox1 <> "") End Sub ★OptionButton选项按钮的使用方法 If OptionButton1.Value = True Then Range("A1" ).Value = "现金" If OptionButton2.Value = True Then Range("A1" ).Value = "加油卡" End If End If VBA求和 ★用VBA进行求和 Sub 横向求和 () Dim i As Long For i = 2 To 10 Range("G" & i) = "=sum(A" & i & ":F" & i & ")" Next i End Sub Sub 横向求和 () Range("G2:G10").value = "=SUM(A2:F2)" End Sub Sub 纵向求和 () i = Range("B65536").End(3).Row + 1 Range("B" & i) = "合计" 在表尾添加“合计”标记 Range("C" & i & ":E" & i).value= "=SUM(C2:C" & i - 1 & ")" End Sub ★用Format定义值的属性 Private Sub Worksheet_Activate() Dim Q Q = Range("A65536").End(3).Row + 1 Range("A" & Q) = Format(Q - 1, "0000") End Sub Label3.Caption = Format(Date, "yyyy年m月D日 aaa") Label2.Caption = "共找到 " & ListView1.ListItems.Count & " 条记录" ★ListView控件双击事件 Private Sub ListView1_DblClick() A= Range("A65536").End(3).Row + 1 Cells(A, 1) = ListView1.SelectedItem '工作表单元格赋值 End Sub 排序 Sub 排序 () With Sheet2 .Range("BG4:BH50").Sort Key1:=.Range("BG4") End With End Sub MsgBox 对话框内文字格式 MsgBox "××××××××", 1 + 64, "××××" 分析:以上是一个简单的对话框,MsgBox “A”, B + C, “D” A:对话框文字 B:当它是1的时候,出现“确定”、“取消”按钮。 当它是0的时候,出现“确定”按钮。 当它是2的时候,出现“终止”、“重试”、“忽略”按钮 C:警示符号代码:当它是64的时候,出现“!”。当它是32的时候,出现“?” 当它是 16的时候,出现“×”。当它是48的时候,出现“!” D:对话框标题文字,如果没有文字,则默认为Microsoft Excel 注意:如果对话框文字较多,可以通过 &chr(10)& 进行换行 示例: Sub输入数值() Dim x x=InputBox(“请输入数据”, “A1中输入数据”,100) Range(“A1”)=x End sub ★ 禁止在其他页面时退出(使工作表右上角关闭按钮无效) Private Sub Workbook_BeforeClose(Cancel As Boolean) If ActiveSheet.Name = "001" Then 如果当前(活动)工作表名称是001,那么: ActiveWorkbook.Save 保存活动工作簿 Else: Cancel = True 否则取消 MsgBox "请返回到首页退出系统!", vbCritical, "帮助" End If End Sub ★ 防止对话框隐藏在后台(使对话框右上角关闭按钮无效) Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True End If End Sub 以下四个是提取单位名称组合框的赋值代码: ①Private Sub UserForm_Initialize() Dim myArray As Variant Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("单位") '指定工作表 myArray = ws.Range("B3:B200").Value '为组合框置项目 With ComboBox1 .List = myArray .ColumnCount = 2 .ColumnHeads = True .ListStyle = fmListStyleOption End With End Sub ②Private Sub UserForm_Initialize() '直接从数据库提取,可以忽略单位名称重复 ComboBox1.Clear For i = 4 To Sheets("数据库").[a65536].End(3).Row If WorksheetFunction.CountIf(Sheets("数据库").Range("a4:a" & i), Sheets("数据库").Range("a" & i)) = 1 Then ComboBox1.AddItem Sheets("数据库").Range("a" & i) End If Next i End Sub ③Private Sub UserForm_Initialize() '如果复制范围固定并且简单,可直接加上参数 ComboBox1.Clear ComboBox1.List = Array("北京", "上海", "重庆", "深圳") End Sub ④Private Sub UserForm_Initialize() '同时设置ListBox的列宽 ListBox1.ColumnWidths = "60;70;60;180;60;140" ListBox1.RowSource = Sheet1.[C2] '设定ListBox的取值范围(参考单元格C2里的公式) End Sub ★一个单位名称录入的对话框案例 Private Sub CommandButton1_Click() A = ComboBox1.Value Range("H3").Value = A 'ComboBox1.Value = "" 可以清空对话框值 Unload Me End Sub 分析:以上是点击“确定”按钮,将对话框的值赋予单元格H3 Private Sub CommandButton3_Click() A = ComboBox1.Value i = Sheets("单位").Range("B65536").End(3).Row + 1 If Application.CountIf(Sheets("单位").Range("B3:B" & i), A) = 0 Then '判断数据的非重复性 Sheets("单位").Range("B" & i) = A Sheet1.Select Unload Me Else MsgBox "单位已存在,请重新输入", , "提示" ComboBox1.Value = "" End If End Sub ★ 鼠标单击事件 Private Sub Worksheet_SelectionChange(ByVal Target As Range) '一个修改提醒代码 If Target.Row < 8 Then Exit Sub '如果选中一个单元格行数小于8(限定于所需表格范围) If Target.Count = 1 Then '如果只选中一个单元格(避免多行改动时也运行下面的程序) If Target.Column = 2 Then '如果修改的是第2列(指定某列进行操作) If Target.Text = "" Then '如果是空白单元格(只对空白单元格进行程序,避免错误修改) Else MsgBox ("业务发生日期不能随意更改") End If End If End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) '弹出对话框 On Error Resume Next If Target.Column = 2 And (Target.Row = 4 Or Target.Row = 18) And Target.Value = "" Then UserForm1.Show End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) '鼠标选定区域变色 On Error Resume Next Range("E4:P4000").Interior.ColorIndex = 0 n = Target.Row Range(Cells(n, 5), Cells(n, 16)).Interior.ColorIndex = 20 '淡蓝色 End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) '禁止对A1单元格进行修改 If Target.Address = "$A$1" Then A = InputBox("请输入密码", "officefans") If A = 1 Then [A1].Select Else [A2].Select End If End Sub ★ 鼠标双击事件,一个弹出对话框代码 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Row = 1 Then Exit Sub '如果鼠标位于第一行,退出代码 If Target.Column = 2 And Target = "" And Target.Offset(-1, 0) <> "" Then '如果鼠标位于第二列、鼠标所在单元格为空值同时鼠标上边单元格非空值,那么: Cancel = True UserForm1.Show End If End Sub ★ 保存数据并退出 Sub 存盘退出 () Application.ScreenUpdating = False '关闭屏幕更新 Dim wb As Workbook MsgBox "是否存盘并结束操作!" For Each wb In Application.Workbooks wb.Save Next wb Application.ScreenUpdating = True '屏幕更新 Application.Quit End Sub 数据筛选 Sub 数据刷新() [A5:M10000].AutoFilter Field:=5, Criteria1:="*" & [A1] & "*", Operator:=xlAnd End Sub Sub 全部显示() On Error Resume Next ActiveSheet.ShowAllData End Sub ★分类保存 按表格名称分类保存1 Sub 保存() A = Sheet2.[D1] B = Sheet3.[D1] C = Sheet4.[D1] D = [G10:H10] If [H2] = "甲公司" Then Sheet2.Range(A) = D ElseIf [H2] = "乙公司" Then Sheet3.Range(B) = D ElseIf [H2] = "丙公司" Then Sheet4.Range(C) = D End If End Sub 按表格名称分类保存2 Sub 保存() C = [A1] 复制源坐标 E = [C5] 从C5单元格提取单位名称 F = Sheets(E).[J3] 该单位表格复制点坐标 Sheets(E).Range(F) = C End Sub 从表外各工作表截取数据 Sub 取数() Sheets("Sheet1").Select Dim 路径$, 数据源$, AK As Workbook, aRow%, tRow% [C5:F50] = "" '冻结屏幕,以防屏幕抖动 Application.ScreenUpdating = False 路径 = ThisWorkbook.Path & "\分表\" '把文件路径定义给变量 数据源 = Dir(路径 & "*.xls") '依次找寻指定路径中的*.xls文件 Do While 数据源 <> "" '当指定路径中有文件时进行循环 If 数据源 <> ThisWorkbook.Name Then Set jin = Workbooks.Open(路径 & 数据源) '打开符合要求的文件 aRow = jin.Sheets(1).Range("a65536").End(3).Row tRow = ThisWorkbook.Sheets(1).Range("c65536").End(3).Row + 1 jin.Sheets(1).Range("a2:I" & aRow).Copy ThisWorkbook.Sheets(1).Range("c" & tRow) Workbooks(数据源).Close False '关闭源工作簿,并不作修改 End If 数据源 = Dir '找寻下一个*.xls文件 Loop Application.ScreenUpdating = True End Sub ★去除UserForm上的关闭按钮 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Const MF_BYPOSITION = &H400 Private Sub UserForm_Initialize() mywin = FindWindow(vbNullString, Me.Caption) SYSTEMmenu = GetSystemMenu(mywin, 0) Res = RemoveMenu(SYSTEMmenu, 5, MF_BYPOSITION) Res = RemoveMenu(SYSTEMmenu, 5, MF_BYPOSITION) End Sub ★ Excel表格屏幕正常显示 On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息 Application.ScreenUpdating = False '关闭屏幕更新 Application.DisplayFormulaBar = True 公式栏显示 Application.DisplayStatusBar = True 状态栏显示 Application.DisplayFullScreen = False 关闭全屏显示 For i = 1 To Application.CommandBars.Count 命令条计数1至Count Application.CommandBars(i).Enabled = True 显示命令条 Next Application.ScreenUpdating = True '开启屏幕更新 ★打开全部隐藏工作表 Sub 取消隐藏 () Application.ScreenUpdating = False '关闭屏幕刷新 Dim i As Integer For i = 1 To Sheets.Count Sheets(i).Visible = True Next i Application.ScreenUpdating = True '打开屏幕刷新 End Sub ★ 一个最简单的密码登录系统 先设置工作簿打开时执行代码: Private Sub Workbook_Open() Sheet2.Select '将表2设置成全空白 Application.Visible = False '关闭屏幕刷新 UserForm1.Show '弹出对话框1 End Sub 然后设置对话框“确认”按钮代码: Private Sub CommandButton1_Click() A = TextBox1.Text If "888888" = A Then Application.Visible = True Sheet2.Select Unload Me Else MsgBox "密码错误,系统退出!" Application.Visible = True Application.Quit End If End Sub Private Sub CommandButton2_Click() Unload Me Application.Quit End Sub ★ 设置用户权限密码登录系统的格式 IF判断密码准确性 关闭对话框 保护所有工作表 IF判断用户性质 解除工作表保护 ElseIf判断其他用户 保护所有工作表 Else End If Else 密码错误即退出 End If 示例: Private Sub CommandButton1_Click() Sheet4.Select Application.ScreenUpdating = False Sheet1.[B15] = ComboBox1.Text '复制用户名 Sheet1.[A15] = TextBox1.Text '复制密码 If Sheet1.[A15] = Sheet1.[D15] Then '如果:核对用户名及密码是否匹配,那么 Application.Visible = True '取消工作表的隐藏 Unload Me '关闭对话框 BH '保护工作表 If Sheet1.[C15] = 1 Then MsgBox "系统管理员:权限-全部", , "提示" JC '解除保护工作表 Sheet3.Select ElseIf Sheet1.[C15] = 2 Then MsgBox "非系统管理员:权限-查看", , "提示" BH Sheet4.Select Else End If Application.ScreenUpdating = True Else MsgBox "密码错误,系统退出!", , "提示" Application.Visible = True Application.ScreenUpdating = True Application.Quit End If Application.ScreenUpdating = True End Sub ● 在A列查找并激活(自动上移) 说明:将要查找的数值录入到“J1”单元格,如果A列里有符合的值,就Select。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$1" Then ’如果鼠标地址是“J1”时 Range("a:a").Find(Target, , , xlWhole).Select ’在A列查找并激活 End If ’如果句结束 End Sub ● 光标自动回到C列 说明:当鼠标点击A列以外的区域,光标回到C列。在这里设置了一个例外条件:当A1单元格为“*”时,不执行该代码。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) '单元格触发事件 Dim TempRag As Range Set TempRag = Application.Selection If Range("A1") = "*" Then Exit Sub If (TempRag.Column <> 1) Then 'Range("A1").Select 也可以设为单元格的select Cells(TempRag.Row, 3).Select End If End Sub ● 在E2单元格输入数值后,回车可以自动填充到B列里,并终止重复输入 说明:这里设置了一个密码解除和重新加密的步骤 Private Sub Worksheet_Change(ByVal Target As Range) '单元格触发事件 i = Range("B65536").End(3).Row + 1 '寻找B列中末行行数并加1,作为复制参照值 If Target.Address <> "$E$2" Then Exit Sub '当鼠标地址不等于E2时,不执行代码 If Target = "" Then Exit Sub '为空值时,不执行代码 If Application.CountIf(Range("B7:B" & i), Range("E2")) = 0 Then '当计算B列的值不重复于E2的值时 'Sheets("**").Unprotect ("123") '解除保护 Range("B" & i).Value = Range("E2") 'Sheets("**").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保护 Range("E2").Select '激活E2 Target = "" ' 清空鼠标的值 Else ' 另外 Range("E2").Select MsgBox "“" & Target.Value & "”已存在,请重新输入", , "提示" Target = "" End If End Sub ● 数据筛选 说明:这里的:="*" & [e3] & "*"是筛选条件,而且采用了通配符*加数值的结合。如果将它改成“*”,则视为对非空白单元格的筛选。 Sub 数据刷新() Sheets("sheet1").Unprotect ("123") '解除保护 [a5:m65536].AutoFilter Field:=5, Criteria1:="*" & [e3] & "*", Operator:=xlAnd Sheets("sheet1").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保护 End Sub Sub 全部显示() On Error Resume Next Sheets("sheet1").Unprotect ("123") '解除保护 ActiveSheet.ShowAllData Sheets("sheet1").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保护 End Sub ● 限定值 说明:★限定了执行区域,避免整个工作表都被限定值 Private Sub Worksheet_Change(ByVal Target As Range) '单元格触发事件 If Target.Count > 1 Then Exit Sub If Target.Row > 1 And Target.Column = 3 Then '要求选定的单元格行数大于1列数等于3 If Target > 100 Then MsgBox "第 " & Target.Row & " 行,你输入的值大于100,请新输入!!!", 0 + 48 Application.EnableEvents = False Target = "" Application.EnableEvents = True End If End If End Sub ● 冻结窗口的操作 说明:以H3单元格为冻结窗口的分界坐标 Sub 冻结窗口() Range("H3").Select MsgBox "冻结窗格" ActiveWindow.FreezePanes = True End Sub Sub 取消冻结窗口() MsgBox "取消冻结窗格" ActiveWindow.FreezePanes = False End Sub ● 自动筛选及解除筛选 Sub 筛选 () ActiveSheet.Unprotect Password:="123456789" 解除工作表密码 Selection.AutoFilter Field:=2, Criteria1:="1" 对第二列进行自动筛选,筛选标准是1 ActiveSheet.Protect Password:="123456789" 加上工作表密码 End Sub Sub 展开 () ActiveSheet.Unprotect Password:="123456789" Selection.AutoFilter Field:=2 ActiveSheet.Protect Password:="123456789" End Sub ● 两个区域的值相互置换 Sub 区域互换() Dim XR As Range, YR As Range Dim SZ1, SZ2, Down If Selection.Areas.Count = 2 Then Set XR = Selection.Areas(1) Set YR = Selection.Areas(2) If Not Intersect(XR, YR) Is Nothing Then Down = MsgBox(" 选择区域有重叠!" & vbCrLf & _ "对换后数据将有部份被覆盖!" & vbCrLf & _ " 是否继续?", vbYesNo) If Down = vbNo Then Exit Sub End If If XR.Rows.Count = YR.Rows.Count And XR.Columns.Count = YR.Columns.Count Then SZ1 = XR.Formula SZ2 = YR.Formula XR = SZ2 YR = SZ1 Else MsgBox "选择的两个区域不相同!" End If Else MsgBox "请选择二个相同的区域!" End If End Sub ● 对话框选择性按钮样式 If MsgBox(" " & Chr(10) & " ", vbYesNo, "提示") = vbYes Then End If 理解:这是一个典型的选择yes和no的对话框,当选择no时终止程序继续运行。中间chr(10)是起到换行作用的,同时要注意以end if 作为结束句 示例: Dim X X = Range("E5") If MsgBox("支票#" & X & "打印," & Chr(10) & "请核对号码", vbYesNo, "提示") = vbYes Then 理解:我们加了一个X为变量,是提取支票号码,使该号码能加入到提示句中。 ● 使用对话框逐行输入1 示例:增加单位名称 Dim A As Variant Dim i As Variant i = Range("D65536").End(3).Row + 1 A = InputBox("请输入新增单位名称", "新增单位", "上海") Range("D" & i).Value = A Range("E12") = A 理解:首先设置两个变量A(提取对话框的值)和i(提取D列末位行+1),然后将该行的值赋为A,同时单元格E12的值也赋为A。 ●使用对话框逐行输入2 Private Sub CommandButton1_Click() Dim A As Variant Dim i As Variant i = Range("D65536").End(3).Row + 1 A = ComboBox1.Value Range("D" & i).Value = A End Sub ------------------------------------------------------------ Private Sub CommandButton2_Click() End End Sub -------------------------------------------------------------- Private Sub UserForm_Initialize() Dim myArray As Variant Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets(1) '指定工作表 myArray = ws.Range("A1:B10").Value '为组合框置项目 With ComboBox1 .List = myArray .ColumnCount = 2 .ColumnHeads = True .ListStyle = fmListStyleOption End With End Sub ●把B1到B12单元格的数据填入c1到c12 Sub 复制() For i = 1 To 12 Range("C" & i) = Range("B" & i) Next i End Sub ●定制自己的状态栏 Application.StatusBar = "现在时刻: " & Time 恢复自己的状态栏 Application.StatusBar = false ●用Range引用单元格和单元格区域 Range("A1") 单元格A1 Range("A1:B5") 从单元格A1到B5区域 Range("A1:B5 ,B1:B7") 多块的选定区域 Range("A:A") A列 Range("1:1") 第一行 Range("A:C") A列到C列的区域 Range("1:5") 第1行到第5行的区域 Range("1:1,3:3") 第1、3行 Range("A:A,C:C") A列、C列 Cells (6,1) 是代表A6单元格 ●把别的工作表Sheet2数据,读到当前工作表的方法列举 1)[A1]=Sheet2.[A1] 把Sheet2A1单元格的数据,读到A1单元格 2)[A2:A4]=Sheet2.[B1] 把Sheet2单元格B1的数据读到A2:到A4单元格 3)Range(B1”)=Sheet2.Range(“B1”) 把Sheet2工作表单元格B1数据,读到B1单元格 4)Range(“C1:C3”)=Sheet2.Range(“C1”) 把Sheet2工作表单元格C1数据,读到C1:C3 5)Cells(1,4)=Sheet2Cells(1,4) 把Sheet2工作表单元格D1数据,读到D1 单元格 6)Range(Cells(1,5),Cells(5,5)=Sheet2.Cells(1,5) 把sheet2工作表单元格E1数据,读到E1:E5单元格 7)Selection.Value=Sheet2.[F1] 把Sheet2 工作表单元格[F1]数据,读到任何你点选的单元格 ●在对话框里设置下拉框 Private Sub UserForm_Initialize() '加载列表框数据 ComboBox1.Clear For i = 4 To Sheets("数据库").[b65536].End(3).Row If WorksheetFunction.CountIf(Sheets("数据库").Range("b4:b" & i), Sheets("数据库").Range("b" & i)) = 1 Then ComboBox1.AddItem Sheets("数据库").Range("b" & i) End If Next i End Sub ■在工作表里添加3个下拉框 Private Sub CBox1() ComboBox1.Clear For i = 3 To Sheets("数据库").[c65536].End(3).Row If WorksheetFunction.CountIf(Sheets("数据库").Range("c1:c" & i), Sheets("数据库").Range("c" & i)) = 1 Then ComboBox1.AddItem Sheets("数据库").Range("c" & i) End If Next i End Sub ******************* Private Sub CBox2() ComboBox2.Clear For i = 3 To Sheets("数据库").[c65536].End(3).Row If WorksheetFunction.CountIf(Sheets("数据库").Range("c1:c" & i), Sheets("数据库").Range("c" & i)) = 1 Then ComboBox2.AddItem Sheets("数据库").Range("c" & i) End If Next i End Sub ******************** Private Sub CBox3() ComboBox3.Clear For i = 3 To Sheets("数据库").[b65536].End(3).Row If WorksheetFunction.CountIf(Sheets("数据库").Range("b1:b" & i), Sheets("数据库").Range("b" & i)) = 1 Then ComboBox3.AddItem Sheets("数据库").Range("b" & i) End If Next i End Sub ******************* Private Sub Worksheet_Activate() Call CBox1 Call CBox2 Call CBox3 End Sub ■ 行列选中后高亮显示 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Row < 5 Then Exit Sub Range(Cells(6, 2), Cells(360, 54)).Interior.ColorIndex = 0 清除原有着色 n = Target.Row m = Target.Column Range(Cells(n, 2), Cells(n, 54)).Interior.ColorIndex = 20 制定范围着色(天蓝色) Range(Cells(6, m), Cells(360, m)).Interior.ColorIndex = 20 End Sub ■ 跟随鼠标的浮动对话框(或按钮) Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'CommandButton1.Top = Range("a1", ActiveCell).Height 'CommandButton1.Left = Range("a1", ActiveCell).Width UserForm1.Top = Range("a1", ActiveCell).Height + 75 UserForm1.Left = Range("a1", ActiveCell).Width + 25 End Sub ■ 复制“模板”,并以对话框内容命名 Private Sub CommandButton1_Click() If TextBox1.Text = "" Then MsgBox ("请填写单位简称"): Exit Sub 名称 = ThisWorkbook.Path & "\" & TextBox1.Text & ".xls" With Workbooks.Open(ThisWorkbook.Path & "\模板.xls") .SaveCopyAs (名称) .Close End With ThisWorkbook.Save Unload Me End Sub ■ 对工作表屏蔽,须解密后查看 Private Sub Worksheet_Activate() '当激活工作表时弹出对话框 UserForm1.Show End Sub ****************** Private Sub Worksheet_Deactivate() '工作表转为非活动状态,字体设为白色 Sheets("sheet1").Cells.Font.ColorIndex = 2 End Sub ****************** Private Sub CommandButton1_Click() Unload Me If TextBox1.Value = 123456 Then Range("A1").Select Sheets("sheet1").Cells.Font.ColorIndex = 1 '激活工作表后,字体恢复设为黑色 Else MsgBox "对不起,您输入的密码错误, 您没有权利查看此表!" Sheets("sheet2").Select End If End End Sub ******************* Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = True ' 使对话框关闭按钮无效 End Sub ■ 对话框居中动态逐渐放大 Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal Hwnd As Long, lpRect As RECT) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const GWL_STYLE As Long = (-16) Private Const WS_CAPTION As Long = &HC00000 Private Const VK_ESCAPE = &H1B Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long Const SM_CXSCREEN = 0 Const SM_CYSCREEN = 1 Dim VidWidth As Integer, VidHeight As Integer Dim Hwnd As Long ****************** Private Sub Explode(Newform As UserForm, Increment As Integer) Dim Size As RECT GetWindowRect Hwnd, Size Dim TempDC TempDC = GetDC(0) Dim Count, LeftPoint, TopPoint, nWidth, nHeight As Integer For Count = 1 To Increment ' loop to new sizes nWidth = Me.Width * (Count / Increment) '每次增加的宽度 nHeight = Me.Height * (Count / Increment) '每次增加的高度 LeftPoint = VidWidth / 2 + (Me.Width - nWidth) / 2 - Me.Width / 2 TopPoint = VidHeight / 2 + (Me.Height - nHeight) / 2 - Me.Height / 2 Rectangle TempDC, LeftPoint, TopPoint, LeftPoint + nWidth, TopPoint + nHeight Next Count DeleteDC (TempDC) End Sub ***************** Private Sub UserForm_Initialize() VidWidth = GetSystemMetrics32(SM_CXSCREEN) VidHeight = GetSystemMetrics32(SM_CYSCREEN) If Val(Application.Version) < 9 Then Hwnd = FindWindow("ThunderXFrame", Me.Caption) '获取窗口句柄 Else Hwnd = FindWindow("ThunderDFrame", Me.Caption) '获取窗口句柄 End If IStyle = GetWindowLong(Hwnd, GWL_STYLE) IStyle = IStyle And WS_CAPTION SetWindowLong Hwnd, GWL_STYLE, IStyle DrawMenuBar Hwnd Explode Me, 10000 End Sub ■ 无边框的对话框 Option Explicit ***************** Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Const GWL_STYLE As Long = (-16) Private Const GWL_EXSTYLE = (-20) Private Const WS_CAPTION As Long = &HC00000 Private Const WS_EX_DLGMODALFRAME = &H1& ************************* Private Sub UserForm_Initialize() Dim IStyle As Long Dim Hwnd As Long If Val(Application.Version) < 9 Then Hwnd = FindWindow("ThunderXFrame", Me.Caption) Else Hwnd = FindWindow("ThunderDFrame", Me.Caption) End If IStyle = GetWindowLong(Hwnd, GWL_STYLE) IStyle = IStyle And Not WS_CAPTION SetWindowLong Hwnd, GWL_STYLE, IStyle DrawMenuBar Hwnd IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME SetWindowLong Hwnd, GWL_EXSTYLE, IStyle 'Application.OnTime Now + TimeValue("00:00:15"), "CloseForm" End Sub *************** Private Sub UserForm_Click() Unload Me '单击窗体后关闭 End Sub ■ 选择性的将数据填进ListBox里 ****************** Private Sub COMBOBOX1_Change() On Error Resume Next Dim myArray As Variant Dim ws As Worksheet If ComboBox1.Text = "" Then Exit Sub Set ws = ThisWorkbook.Worksheets("职工工资") '指定工作表 yf = ComboBox1.Text & "01" If Application.CountIf(Sheet4.Range("b:b"), yf) = 0 Then MsgBox ("该月没有数据"): Exit Sub hs = Sheet4.Range("b:b").Find(yf).Row - 1 myArray = ws.Range("C" & hs & ":Q" & hs + 14).Value '为组合框置项目 With ListBox1 .List = myArray .ColumnCount = 15 ' .ColumnHeads = True '.ListStyle = fmListStyleOption End With ListBox1.ColumnWidths = "50;40;30;30;45;55;55;50;45;45;45;45;40;70;55;55" End Sub 分析:根据ComboBox1提供的日期(如201102)自动转化成20110201以便查找该月份发生数据所在的行,这样就可以动态的加载ListBox1数据了。 ****************** Private Sub CommandButton1_Click() If ComboBox1.Text = "" Then MsgBox ("没有选择日期"): Exit Sub Sheet22.[L4] = ComboBox1.Text Sheet22.Select Unload Me End Sub ******************* Private Sub CommandButton2_Click() End End Sub 1.编辑栏 Application.DisplayFormulaBar = False '隐藏编辑栏 Application.DisplayFormulaBar = True '显示编辑栏 2.常用工具栏 Application.CommandBars("Standard").Visible = False Application.CommandBars("Standard").Visible = True 3. 格式工具栏 Application.CommandBars("Formatting").Visible = False Application.CommandBars("Formatting").Visible = True 4.更改标题 Application.Caption = " " '输入需要的标题内容 Application.Caption = vbNullString '恢复默认的标题文字 5.关闭工作表 ThisWorkbook.Close 6.保存工作表 ActiveWorkbook.Save 7.状态栏 Application.DisplayStatusBar = False '隐藏状态栏 Application.DisplayStatusBar = True '显示状态栏 8.屏幕刷新 Application.ScreenUpdating = False '屏幕刷新功能停止(运行速度加快) Application.ScreenUpdating = True '屏幕刷新功能启动 9.工作表隐藏 Application.Visible = False Application.Visible = True 10.自动和手动计算 Application.Calculation = xlCalculationAutomatic '自动计算 Application.Calculation = xlCalculationManual '手动计算 11.更改状态栏 Application.StatusBar = " " Application.StatusBar = vbNullString |
|