《通過(guò)實(shí)例來(lái)學(xué)習(xí)VBA代碼》
數(shù)據(jù)的復(fù)制
★從其他工作表里復(fù)制數(shù)據(jù)
Sub 復(fù)制()
Sheet1.Range("A1:I40").Value = ThisWorkbook.Path \ [1.xls].Sheet1.Range("A1:I40").Value
End Sub
★批量復(fù)制
Sub 復(fù)制()
For i = 1 To 12
Range("C" & i) = Range("B" & i)
Next i
End Sub
★數(shù)據(jù)疊加
Sub累計(jì)()
If (vbOK = MsgBox("數(shù)據(jù)匯總?", 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
★ 復(fù)制對(duì)話框的值
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
設(shè)置工作表密碼
ActiveSheet.Protect Password:=888888 ' 保護(hù)工作表并設(shè)置密碼
ActiveSheet.Unprotect Password:=888888 '撤消工作表保護(hù)并取消密碼
打印設(shè)置
★對(duì)部分區(qū)域進(jìn)行打印
Sub 打印表格()
MsgBox "現(xiàn)在打印<其他應(yīng)收款>和<其他應(yīng)付款>"
ActiveSheet.PageSetup.PrintArea = "B2:E36" '設(shè)置打印區(qū)域
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=3, Copies:=1, Collate:=True
MsgBox "現(xiàn)在打印<預(yù)收賬款>和<應(yīng)繳稅金>"
ActiveSheet.PageSetup.PrintArea = "B39:E74"
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=3, Copies:=1, Collate:=True
ActiveSheet.PageSetup.PrintArea = "" '取消打印區(qū)域的設(shè)置"
MsgBox "打印完畢！"
End Sub
★進(jìn)入打印預(yù)覽
Sub 打印預(yù)覽()
ActiveWindow.SelectedSheets.PrintPreview
End Sub
★ 直接打印
Sub 直接打印()
ActiveWindow.SelectedSheets .PrintOut From:=1, To:=3, Copies:=1, Collate:=True
End Sub
自動(dòng)運(yùn)行
★ 打開工作薄自動(dòng)運(yùn)行：Private Sub Workbook_Open()
★ 關(guān)閉工作薄自動(dòng)運(yùn)行：Private Sub Workbook_BeforeClose(Cancel As Boolean)
★ 打開對(duì)話框自動(dòng)運(yùn)行：Private Sub UserForm_Initialize()
★ 工作表激活后執(zhí)行：Private Sub Worksheet_Activate()
■條件退出程序代碼的基本形式If [ ] = "" Then MsgBox ("沒(méi)有數(shù)據(jù)"): Exit Sub
■執(zhí)行代碼前詢問(wèn)形式：If (vbOK = MsgBox("是否執(zhí)行操作?", vbOKCancel)) Then
加快速度
Application.ScreenUpdating = False '關(guān)閉屏幕刷新
Application.Calculation = xlCalculationManual '手動(dòng)重算
Application.Calculation = xlCalculationAutomatic '自動(dòng)重算
Application.ScreenUpdating = True '打開屏幕刷新
逐行輸入
★ 逐行錄入（一）
Sub 產(chǎn)品入庫(kù)()
Q = Range("C65536").End(3).Row + 1
Range("C" & Q & ":I" & Q).Value = Range("C20:I20").Value
End Sub
★ 逐行錄入（二）
領(lǐng)會(huì)For的用法：基本形式for…to….next
Sub 產(chǎn)品入庫(kù)()
If Range("C1") > 59 Then Exit Sub '當(dāng)數(shù)據(jù)錄入超過(guò)59行，停止運(yùn)行本程序
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表達(dá)方式，它的坐標(biāo)是（行，列）顯示的，如：Cells(7, 1)是指A7
★逐行錄入（三）
Sub 記帳()
If [H3] = "" Then MsgBox ("請(qǐng)?zhí)顚憜挝幻Q"): Exit Sub
A = [D3] '復(fù)制源坐標(biāo)
B = [D4] '黏貼點(diǎn)坐標(biāo)
C = Sheet11.Range(A)
Sheet2.Range(B) = C
End Sub
分析：A,B是兩個(gè)單元格區(qū)域坐標(biāo)，首先在任意的單元格里用函數(shù)定義坐標(biāo)，分別代表數(shù)據(jù)復(fù)制源和黏貼點(diǎn)。然后將坐標(biāo)結(jié)合在相應(yīng)的工作表名稱上，通過(guò)C來(lái)復(fù)制。
利用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 "沒(méi)有找到！" & 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的范圍里查找包含數(shù)字5的單元格，并設(shè)置成紅色。
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("合計(jì)").Row - 1 '尋找“合計(jì)”所在行-1
Rows(A).Copy '復(fù)制
Rows(A).Insert Shift:=xlDown '方向向下移動(dòng)
Application.CutCopyMode = False
End Sub
Sub 刪除行()
If Range("M2") < 13 Then Exit Sub
B = Range("a:a").Find("合計(jì)").Row - 1 '尋找“合計(jì)”所在行-1
Rows(B).Delete Shift:=3 '方向向上移動(dòng)
End Sub
分析：1.該示例設(shè)定了增加、刪除行的限定范圍。
2.利用查找某行數(shù)值（“合計(jì)”）來(lái)定位復(fù)制或刪除的行數(shù)。
Sub 增加行二()
On Error Resume Next '忽略錯(cuò)誤
Dim r As Long '設(shè)置變量r
r = ActiveCell.Row '將r定義為地前鼠標(biāo)所在行
If r > 3 Then '如果行數(shù)大于3執(zhí)行命令
Rows(r).Insert Shift:=xlDown '所在行向下移動(dòng)
End If
End Sub
Change的運(yùn)用
★ 在對(duì)話框里A輸入數(shù)字，對(duì)話框B同步顯示數(shù)字中文大寫
Private Sub TextBox3_Change()
[I7] = Val(TextBox3)
TextBox4.Value = [D7]
End Sub
分析：首先將textbox3的值賦予“I7”單元格
單元格“D7”的內(nèi)容是中文轉(zhuǎn)換公式
將“D7”的值賦予textbox4
★彈出對(duì)話框的條件
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
★對(duì)話框之間建立勾稽關(guān)系
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表示
★當(dāng)單元格發(fā)生變化時(shí)執(zhí)行程序：
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub '自動(dòng)添加序號(hào)
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
按鈕的激活切換
★凍結(jié)“確認(rèn)”按鈕（當(dāng)兩個(gè)對(duì)話框都有數(shù)據(jù)時(shí)恢復(fù)）
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選項(xiàng)按鈕的使用方法
If OptionButton1.Value = True Then
Range("A1" ).Value = "現(xiàn)金"
If OptionButton2.Value = True Then
Range("A1" ).Value = "加油卡"
End If
End If
VBA求和
★用VBA進(jìn)行求和
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) = "合計(jì)" 在表尾添加“合計(jì)”標(biāo)記
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 & " 條記錄"
★L(fēng)istView控件雙擊事件
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
對(duì)話框內(nèi)文字格式
MsgBox "××××××××", 1 + 64, "××××"
分析：以上是一個(gè)簡(jiǎn)單的對(duì)話框，MsgBox “A”, B + C, “D”
A：對(duì)話框文字
B：當(dāng)它是1的時(shí)候，出現(xiàn)“確定”、“取消”按鈕。
當(dāng)它是0的時(shí)候，出現(xiàn)“確定”按鈕。
當(dāng)它是2的時(shí)候，出現(xiàn)“終止”、“重試”、“忽略”按鈕
C：警示符號(hào)代碼：當(dāng)它是64的時(shí)候，出現(xiàn)“！”。當(dāng)它是32的時(shí)候，出現(xiàn)“？” 當(dāng)它是
16的時(shí)候，出現(xiàn)“×”。當(dāng)它是48的時(shí)候，出現(xiàn)“！”
D：對(duì)話框標(biāo)題文字，如果沒(méi)有文字，則默認(rèn)為Microsoft Excel
注意：如果對(duì)話框文字較多，可以通過(guò) &chr（10）& 進(jìn)行換行
示例：
Sub輸入數(shù)值（）
Dim x
x=InputBox(“請(qǐng)輸入數(shù)據(jù)”, “A1中輸入數(shù)據(jù)”,100)
Range(“A1”)=x
End sub
★ 禁止在其他頁(yè)面時(shí)退出（使工作表右上角關(guān)閉按鈕無(wú)效）
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ActiveSheet.Name = "001" Then 如果當(dāng)前（活動(dòng)）工作表名稱是001，那么：
ActiveWorkbook.Save 保存活動(dòng)工作簿
Else: Cancel = True 否則取消
MsgBox "請(qǐng)返回到首頁(yè)退出系統(tǒng)！", vbCritical, "幫助"
End If
End Sub
★ 防止對(duì)話框隱藏在后臺(tái)（使對(duì)話框右上角關(guān)閉按鈕無(wú)效）
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
以下四個(gè)是提取單位名稱組合框的賦值代碼：
①Private Sub UserForm_Initialize()
Dim myArray As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("單位") '指定工作表
myArray = ws.Range("B3:B200").Value '為組合框置項(xiàng)目
With ComboBox1
.List = myArray
.ColumnCount = 2
.ColumnHeads = True
.ListStyle = fmListStyleOption
End With
End Sub
②Private Sub UserForm_Initialize() '直接從數(shù)據(jù)庫(kù)提取，可以忽略單位名稱重復(fù)
ComboBox1.Clear
For i = 4 To Sheets("數(shù)據(jù)庫(kù)").[a65536].End(3).Row
If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫(kù)").Range("a4:a" & i), Sheets("數(shù)據(jù)庫(kù)").Range("a" & i)) = 1 Then
ComboBox1.AddItem Sheets("數(shù)據(jù)庫(kù)").Range("a" & i)
End If
Next i
End Sub
③Private Sub UserForm_Initialize() '如果復(fù)制范圍固定并且簡(jiǎn)單，可直接加上參數(shù)
ComboBox1.Clear
ComboBox1.List = Array("北京", "上海", "重慶", "深圳")
End Sub
④Private Sub UserForm_Initialize() '同時(shí)設(shè)置ListBox的列寬
ListBox1.ColumnWidths = "60;70;60;180;60;140"
ListBox1.RowSource = Sheet1.[C2] '設(shè)定ListBox的取值范圍（參考單元格C2里的公式）
End Sub
★一個(gè)單位名稱錄入的對(duì)話框案例
Private Sub CommandButton1_Click()
A = ComboBox1.Value
Range("H3").Value = A
'ComboBox1.Value = "" 可以清空對(duì)話框值
Unload Me
End Sub
分析：以上是點(diǎn)擊“確定”按鈕，將對(duì)話框的值賦予單元格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 '判斷數(shù)據(jù)的非重復(fù)性
Sheets("單位").Range("B" & i) = A
Sheet1.Select
Unload Me
Else
MsgBox "單位已存在，請(qǐng)重新輸入", , "提示"
ComboBox1.Value = ""
End If
End Sub
★ 鼠標(biāo)單擊事件
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '一個(gè)修改提醒代碼
If Target.Row < 8 Then Exit Sub '如果選中一個(gè)單元格行數(shù)小于8（限定于所需表格范圍）
If Target.Count = 1 Then '如果只選中一個(gè)單元格（避免多行改動(dòng)時(shí)也運(yùn)行下面的程序）
If Target.Column = 2 Then '如果修改的是第2列（指定某列進(jìn)行操作）
If Target.Text = "" Then '如果是空白單元格（只對(duì)空白單元格進(jìn)行程序，避免錯(cuò)誤修改）
Else
MsgBox ("業(yè)務(wù)發(fā)生日期不能隨意更改")
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '彈出對(duì)話框
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) '鼠標(biāo)選定區(qū)域變色
On Error Resume Next
Range("E4:P4000").Interior.ColorIndex = 0
n = Target.Row
Range(Cells(n, 5), Cells(n, 16)).Interior.ColorIndex = 20 '淡藍(lán)色
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '禁止對(duì)A1單元格進(jìn)行修改
If Target.Address = "$A$1" Then
A = InputBox("請(qǐng)輸入密碼", "officefans")
If A = 1 Then [A1].Select Else [A2].Select
End If
End Sub
★ 鼠標(biāo)雙擊事件，一個(gè)彈出對(duì)話框代碼
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row = 1 Then Exit Sub '如果鼠標(biāo)位于第一行，退出代碼
If Target.Column = 2 And Target = "" And Target.Offset(-1, 0) <> "" Then
'如果鼠標(biāo)位于第二列、鼠標(biāo)所在單元格為空值同時(shí)鼠標(biāo)上邊單元格非空值，那么：
Cancel = True
UserForm1.Show
End If
End Sub
★ 保存數(shù)據(jù)并退出
Sub 存盤退出 （）
Application.ScreenUpdating = False '關(guān)閉屏幕更新
Dim wb As Workbook
MsgBox "是否存盤并結(jié)束操作！"
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.ScreenUpdating = True '屏幕更新
Application.Quit
End Sub
數(shù)據(jù)篩選
Sub 數(shù)據(jù)刷新()
[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] 復(fù)制源坐標(biāo)
E = [C5] 從C5單元格提取單位名稱
F = Sheets(E).[J3] 該單位表格復(fù)制點(diǎn)坐標(biāo)
Sheets(E).Range(F) = C
End Sub
從表外各工作表截取數(shù)據(jù)
Sub 取數(shù)()
Sheets("Sheet1").Select
Dim 路徑$, 數(shù)據(jù)源$, AK As Workbook, aRow%, tRow%
[C5:F50] = "" '凍結(jié)屏幕，以防屏幕抖動(dòng)
Application.ScreenUpdating = False
路徑 = ThisWorkbook.Path & "\分表\" '把文件路徑定義給變量
數(shù)據(jù)源 = Dir(路徑 & "*.xls") '依次找尋指定路徑中的*.xls文件
Do While 數(shù)據(jù)源 <> "" '當(dāng)指定路徑中有文件時(shí)進(jìn)行循環(huán)
If 數(shù)據(jù)源 <> ThisWorkbook.Name Then
Set jin = Workbooks.Open(路徑 & 數(shù)據(jù)源) '打開符合要求的文件
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(數(shù)據(jù)源).Close False '關(guān)閉源工作簿,并不作修改
End If
數(shù)據(jù)源 = Dir '找尋下一個(gè)*.xls文件
Loop
Application.ScreenUpdating = True
End Sub
★去除UserForm上的關(guān)閉按鈕
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 '忽略錯(cuò)誤繼續(xù)執(zhí)行VBA代碼,避免出現(xiàn)錯(cuò)誤消息
Application.ScreenUpdating = False '關(guān)閉屏幕更新
Application.DisplayFormulaBar = True 公式欄顯示
Application.DisplayStatusBar = True 狀態(tài)欄顯示
Application.DisplayFullScreen = False 關(guān)閉全屏顯示
For i = 1 To Application.CommandBars.Count 命令條計(jì)數(shù)1至Count
Application.CommandBars(i).Enabled = True 顯示命令條
Next
Application.ScreenUpdating = True '開啟屏幕更新
★打開全部隱藏工作表
Sub 取消隱藏 ()
Application.ScreenUpdating = False '關(guān)閉屏幕刷新
Dim i As Integer
For i = 1 To Sheets.Count
Sheets(i).Visible = True
Next i
Application.ScreenUpdating = True '打開屏幕刷新
End Sub
★ 一個(gè)最簡(jiǎn)單的密碼登錄系統(tǒng)
先設(shè)置工作簿打開時(shí)執(zhí)行代碼：
Private Sub Workbook_Open()
Sheet2.Select '將表2設(shè)置成全空白
Application.Visible = False '關(guān)閉屏幕刷新
UserForm1.Show '彈出對(duì)話框1
End Sub
然后設(shè)置對(duì)話框“確認(rèn)”按鈕代碼：
Private Sub CommandButton1_Click()
A = TextBox1.Text
If "888888" = A Then
Application.Visible = True
Sheet2.Select
Unload Me
Else
MsgBox "密碼錯(cuò)誤,系統(tǒng)退出！"
Application.Visible = True
Application.Quit
End If
End Sub
Private Sub CommandButton2_Click()
Unload Me
Application.Quit
End Sub
★ 設(shè)置用戶權(quán)限密碼登錄系統(tǒng)的格式
IF判斷密碼準(zhǔn)確性
關(guān)閉對(duì)話框
保護(hù)所有工作表
IF判斷用戶性質(zhì)
解除工作表保護(hù)
ElseIf判斷其他用戶
保護(hù)所有工作表
Else
End If
Else
密碼錯(cuò)誤即退出
End If
示例：
Private Sub CommandButton1_Click()
Sheet4.Select
Application.ScreenUpdating = False
Sheet1.[B15] = ComboBox1.Text '復(fù)制用戶名
Sheet1.[A15] = TextBox1.Text '復(fù)制密碼
If Sheet1.[A15] = Sheet1.[D15] Then '如果：核對(duì)用戶名及密碼是否匹配，那么
Application.Visible = True '取消工作表的隱藏
Unload Me '關(guān)閉對(duì)話框
BH '保護(hù)工作表
If Sheet1.[C15] = 1 Then
MsgBox "系統(tǒng)管理員：權(quán)限-全部", , "提示"
JC '解除保護(hù)工作表
Sheet3.Select
ElseIf Sheet1.[C15] = 2 Then
MsgBox "非系統(tǒng)管理員：權(quán)限-查看", , "提示"
BH
Sheet4.Select
Else
End If
Application.ScreenUpdating = True
Else
MsgBox "密碼錯(cuò)誤,系統(tǒng)退出!", , "提示"
Application.Visible = True
Application.ScreenUpdating = True
Application.Quit
End If
Application.ScreenUpdating = True
End Sub
● 在A列查找并激活（自動(dòng)上移）
說(shuō)明：將要查找的數(shù)值錄入到“J1”單元格，如果A列里有符合的值，就Select。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$J$1" Then ’如果鼠標(biāo)地址是“J1”時(shí)
Range("a:a").Find(Target, , , xlWhole).Select ’在A列查找并激活
End If ’如果句結(jié)束
End Sub
● 光標(biāo)自動(dòng)回到C列
說(shuō)明：當(dāng)鼠標(biāo)點(diǎn)擊A列以外的區(qū)域，光標(biāo)回到C列。在這里設(shè)置了一個(gè)例外條件：當(dāng)A1單元格為“*”時(shí)，不執(zhí)行該代碼。
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '單元格觸發(fā)事件
Dim TempRag As Range
Set TempRag = Application.Selection
If Range("A1") = "*" Then Exit Sub
If (TempRag.Column <> 1) Then
'Range("A1").Select 也可以設(shè)為單元格的select
Cells(TempRag.Row, 3).Select
End If
End Sub
● 在E2單元格輸入數(shù)值后，回車可以自動(dòng)填充到B列里，并終止重復(fù)輸入
說(shuō)明：這里設(shè)置了一個(gè)密碼解除和重新加密的步驟
Private Sub Worksheet_Change(ByVal Target As Range) '單元格觸發(fā)事件
i = Range("B65536").End(3).Row + 1 '尋找B列中末行行數(shù)并加1，作為復(fù)制參照值
If Target.Address <> "$E$2" Then Exit Sub '當(dāng)鼠標(biāo)地址不等于E2時(shí)，不執(zhí)行代碼
If Target = "" Then Exit Sub '為空值時(shí)，不執(zhí)行代碼
If Application.CountIf(Range("B7:B" & i), Range("E2")) = 0 Then '當(dāng)計(jì)算B列的值不重復(fù)于E2的值時(shí)
'Sheets("**").Unprotect ("123") '解除保護(hù)
Range("B" & i).Value = Range("E2")
'Sheets("**").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保護(hù)
Range("E2").Select '激活E2
Target = "" ' 清空鼠標(biāo)的值
Else ' 另外
Range("E2").Select
MsgBox "“" & Target.Value & "”已存在，請(qǐng)重新輸入", , "提示"
Target = ""
End If
End Sub
● 數(shù)據(jù)篩選
說(shuō)明：這里的:="*" & [e3] & "*"是篩選條件，而且采用了通配符*加數(shù)值的結(jié)合。如果將它改成“*”，則視為對(duì)非空白單元格的篩選。
Sub 數(shù)據(jù)刷新()
Sheets("sheet1").Unprotect ("123") '解除保護(hù)
[a5:m65536].AutoFilter Field:=5, Criteria1:="*" & [e3] & "*", Operator:=xlAnd
Sheets("sheet1").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保護(hù)
End Sub
Sub 全部顯示()
On Error Resume Next
Sheets("sheet1").Unprotect ("123") '解除保護(hù)
ActiveSheet.ShowAllData
Sheets("sheet1").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True '重新保護(hù)
End Sub
● 限定值
說(shuō)明：★限定了執(zhí)行區(qū)域，避免整個(gè)工作表都被限定值
Private Sub Worksheet_Change(ByVal Target As Range) '單元格觸發(fā)事件
If Target.Count > 1 Then Exit Sub
If Target.Row > 1 And Target.Column = 3 Then '要求選定的單元格行數(shù)大于1列數(shù)等于3
If Target > 100 Then
MsgBox "第 " & Target.Row & " 行，你輸入的值大于100,請(qǐng)新輸入!!!", 0 + 48
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
End If
End If
End Sub
● 凍結(jié)窗口的操作
說(shuō)明：以H3單元格為凍結(jié)窗口的分界坐標(biāo)
Sub 凍結(jié)窗口()
Range("H3").Select
MsgBox "凍結(jié)窗格"
ActiveWindow.FreezePanes = True
End Sub
Sub 取消凍結(jié)窗口()
MsgBox "取消凍結(jié)窗格"
ActiveWindow.FreezePanes = False
End Sub
● 自動(dòng)篩選及解除篩選
Sub 篩選 ()
ActiveSheet.Unprotect Password:="123456789" 解除工作表密碼
Selection.AutoFilter Field:=2, Criteria1:="1" 對(duì)第二列進(jìn)行自動(dòng)篩選，篩選標(biāo)準(zhǔn)是1
ActiveSheet.Protect Password:="123456789" 加上工作表密碼
End Sub
Sub 展開 ()
ActiveSheet.Unprotect Password:="123456789"
Selection.AutoFilter Field:=2
ActiveSheet.Protect Password:="123456789"
End Sub
● 兩個(gè)區(qū)域的值相互置換
Sub 區(qū)域互換()
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(" 選擇區(qū)域有重疊！" & vbCrLf & _
"對(duì)換后數(shù)據(jù)將有部份被覆蓋！" & vbCrLf & _
" 是否繼續(xù)？", 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 "選擇的兩個(gè)區(qū)域不相同！"
End If
Else
MsgBox "請(qǐng)選擇二個(gè)相同的區(qū)域！"
End If
End Sub
● 對(duì)話框選擇性按鈕樣式
If MsgBox(" " & Chr(10) & " ", vbYesNo, "提示") = vbYes Then
End If
理解：這是一個(gè)典型的選擇yes和no的對(duì)話框，當(dāng)選擇no時(shí)終止程序繼續(xù)運(yùn)行。中間chr（10）是起到換行作用的，同時(shí)要注意以end if 作為結(jié)束句
示例：
Dim X
X = Range("E5")
If MsgBox("支票#" & X & "打印，" & Chr(10) & "請(qǐng)核對(duì)號(hào)碼", vbYesNo, "提示") = vbYes Then
理解：我們加了一個(gè)X為變量，是提取支票號(hào)碼，使該號(hào)碼能加入到提示句中。
● 使用對(duì)話框逐行輸入1
示例：增加單位名稱
Dim A As Variant
Dim i As Variant
i = Range("D65536").End(3).Row + 1
A = InputBox("請(qǐng)輸入新增單位名稱", "新增單位", "上海")
Range("D" & i).Value = A
Range("E12") = A
理解：首先設(shè)置兩個(gè)變量A（提取對(duì)話框的值）和i（提取D列末位行+1），然后將該行的值賦為A，同時(shí)單元格E12的值也賦為A。
●使用對(duì)話框逐行輸入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 '為組合框置項(xiàng)目
With ComboBox1
.List = myArray
.ColumnCount = 2
.ColumnHeads = True
.ListStyle = fmListStyleOption
End With
End Sub
●把B1到B12單元格的數(shù)據(jù)填入c1到c12
Sub 復(fù)制()
For i = 1 To 12
Range("C" & i) = Range("B" & i)
Next i
End Sub
●定制自己的狀態(tài)欄
Application.StatusBar = "現(xiàn)在時(shí)刻: " & Time
恢復(fù)自己的狀態(tài)欄
Application.StatusBar = false
●用Range引用單元格和單元格區(qū)域
Range("A1") 單元格A1
Range("A1:B5") 從單元格A1到B5區(qū)域
Range("A1:B5 ,B1:B7") 多塊的選定區(qū)域
Range("A:A") A列
Range("1:1") 第一行
Range("A:C") A列到C列的區(qū)域
Range("1:5") 第1行到第5行的區(qū)域
Range("1:1,3:3") 第1、3行
Range("A:A,C:C") A列、C列
Cells (6,1) 是代表A6單元格
●把別的工作表Sheet2數(shù)據(jù)，讀到當(dāng)前工作表的方法列舉
1）[A1]=Sheet2.[A1] 把Sheet2A1單元格的數(shù)據(jù)，讀到A1單元格
2）[A2:A4]=Sheet2.[B1] 把Sheet2單元格B1的數(shù)據(jù)讀到A2:到A4單元格
3）Range(B1”)=Sheet2.Range(“B1”) 把Sheet2工作表單元格B1數(shù)據(jù)，讀到B1單元格
4)Range(“C1:C3”)=Sheet2.Range(“C1”) 把Sheet2工作表單元格C1數(shù)據(jù)，讀到C1:C3
5)Cells(1,4)=Sheet2Cells(1,4) 把Sheet2工作表單元格D1數(shù)據(jù)，讀到D1 單元格
6)Range(Cells(1,5),Cells(5,5)=Sheet2.Cells(1,5)
把sheet2工作表單元格E1數(shù)據(jù)，讀到E1:E5單元格
7)Selection.Value=Sheet2.[F1] 把Sheet2 工作表單元格[F1]數(shù)據(jù)，讀到任何你點(diǎn)選的單元格
●在對(duì)話框里設(shè)置下拉框
Private Sub UserForm_Initialize() '加載列表框數(shù)據(jù)
ComboBox1.Clear
For i = 4 To Sheets("數(shù)據(jù)庫(kù)").[b65536].End(3).Row
If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫(kù)").Range("b4:b" & i), Sheets("數(shù)據(jù)庫(kù)").Range("b" & i)) = 1 Then
ComboBox1.AddItem Sheets("數(shù)據(jù)庫(kù)").Range("b" & i)
End If
Next i
End Sub
■在工作表里添加3個(gè)下拉框
Private Sub CBox1()
ComboBox1.Clear
For i = 3 To Sheets("數(shù)據(jù)庫(kù)").[c65536].End(3).Row
If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫(kù)").Range("c1:c" & i), Sheets("數(shù)據(jù)庫(kù)").Range("c" & i)) = 1 Then
ComboBox1.AddItem Sheets("數(shù)據(jù)庫(kù)").Range("c" & i)
End If
Next i
End Sub
*******************
Private Sub CBox2()
ComboBox2.Clear
For i = 3 To Sheets("數(shù)據(jù)庫(kù)").[c65536].End(3).Row
If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫(kù)").Range("c1:c" & i), Sheets("數(shù)據(jù)庫(kù)").Range("c" & i)) = 1 Then
ComboBox2.AddItem Sheets("數(shù)據(jù)庫(kù)").Range("c" & i)
End If
Next i
End Sub
********************
Private Sub CBox3()
ComboBox3.Clear
For i = 3 To Sheets("數(shù)據(jù)庫(kù)").[b65536].End(3).Row
If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫(kù)").Range("b1:b" & i), Sheets("數(shù)據(jù)庫(kù)").Range("b" & i)) = 1 Then
ComboBox3.AddItem Sheets("數(shù)據(jù)庫(kù)").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 制定范圍著色（天藍(lán)色）
Range(Cells(6, m), Cells(360, m)).Interior.ColorIndex = 20
End Sub
■ 跟隨鼠標(biāo)的浮動(dòng)對(duì)話框（或按鈕）
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
■ 復(fù)制“模板”，并以對(duì)話框內(nèi)容命名
Private Sub CommandButton1_Click()
If TextBox1.Text = "" Then MsgBox ("請(qǐng)?zhí)顚憜挝缓?jiǎn)稱"): Exit Sub
名稱 = ThisWorkbook.Path & "\" & TextBox1.Text & ".xls"
With Workbooks.Open(ThisWorkbook.Path & "\模板.xls")
.SaveCopyAs (名稱)
.Close
End With
ThisWorkbook.Save
Unload Me
End Sub
■ 對(duì)工作表屏蔽，須解密后查看
Private Sub Worksheet_Activate() '當(dāng)激活工作表時(shí)彈出對(duì)話框
UserForm1.Show
End Sub
******************
Private Sub Worksheet_Deactivate() '工作表轉(zhuǎn)為非活動(dòng)狀態(tài)，字體設(shè)為白色
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 '激活工作表后，字體恢復(fù)設(shè)為黑色
Else
MsgBox "對(duì)不起，您輸入的密碼錯(cuò)誤, 您沒(méi)有權(quán)利查看此表!"
Sheets("sheet2").Select
End If
End
End Sub
*******************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True ' 使對(duì)話框關(guān)閉按鈕無(wú)效
End Sub
■ 對(duì)話框居中動(dòng)態(tài)逐漸放大
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
■ 無(wú)邊框的對(duì)話框
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 '單擊窗體后關(guān)閉
End Sub
■ 選擇性的將數(shù)據(jù)填進(jìn)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 ("該月沒(méi)有數(shù)據(jù)"): Exit Sub
hs = Sheet4.Range("b:b").Find(yf).Row - 1
myArray = ws.Range("C" & hs & ":Q" & hs + 14).Value '為組合框置項(xiàng)目
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
分析：根據(jù)ComboBox1提供的日期（如201102）自動(dòng)轉(zhuǎn)化成20110201以便查找該月份發(fā)生數(shù)據(jù)所在的行，這樣就可以動(dòng)態(tài)的加載ListBox1數(shù)據(jù)了。
******************
Private Sub CommandButton1_Click()
If ComboBox1.Text = "" Then MsgBox ("沒(méi)有選擇日期"): 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.更改標(biāo)題
Application.Caption = " " '輸入需要的標(biāo)題內(nèi)容
Application.Caption = vbNullString '恢復(fù)默認(rèn)的標(biāo)題文字
5.關(guān)閉工作表 ThisWorkbook.Close
6.保存工作表 ActiveWorkbook.Save
7.狀態(tài)欄
Application.DisplayStatusBar = False '隱藏狀態(tài)欄
Application.DisplayStatusBar = True '顯示狀態(tài)欄
8.屏幕刷新
Application.ScreenUpdating = False '屏幕刷新功能停止（運(yùn)行速度加快）
Application.ScreenUpdating = True '屏幕刷新功能啟動(dòng)
9.工作表隱藏
Application.Visible = False
Application.Visible = True
10.自動(dòng)和手動(dòng)計(jì)算
Application.Calculation = xlCalculationAutomatic '自動(dòng)計(jì)算
Application.Calculation = xlCalculationManual '手動(dòng)計(jì)算
11.更改狀態(tài)欄
Application.StatusBar = " "
Application.StatusBar = vbNullString
