分享

通过实例来学习VBA代码

 jbch88 2013-04-19
《通过实例来学习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









    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。请注意甄别内容中的联系方式、诱导购买等信息,谨防诈骗。如发现有害或侵权内容,请点击一键举报。
    转藏 分享 献花(0

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多