|
《通過實(shí)例來學(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累計() 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ù)制對話框的值 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è)置 ★對部分區(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 自動運(yùn)行 ★ 打開工作薄自動運(yùn)行：Private Sub Workbook_Open() ★ 關(guān)閉工作薄自動運(yùn)行：Private Sub Workbook_BeforeClose(Cancel As Boolean) ★ 打開對話框自動運(yùn)行：Private Sub UserForm_Initialize() ★ 工作表激活后執(zhí)行：Private Sub Worksheet_Activate() ■條件退出程序代碼的基本形式If [ ] = "" Then MsgBox ("沒有數(shù)據(jù)"): Exit Sub ■執(zhí)行代碼前詢問形式：If (vbOK = MsgBox("是否執(zhí)行操作?", vbOKCancel)) Then 加快速度 Application.ScreenUpdating = False '關(guān)閉屏幕刷新 Application.Calculation = xlCalculationManual '手動重算 Application.Calculation = xlCalculationAutomatic '自動重算 Application.ScreenUpdating = True '打開屏幕刷新 逐行輸入 ★ 逐行錄入（一） Sub 產(chǎn)品入庫() Q = Range("C65536").End(3).Row + 1 Range("C" & Q & ":I" & Q).Value = Range("C20:I20").Value End Sub ★ 逐行錄入（二） 領(lǐng)會For的用法：基本形式for…to….next Sub 產(chǎn)品入庫() If Range("C1") > 59 Then Exit Sub '當(dāng)數(shù)據(jù)錄入超過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 ("請?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是兩個單元格區(qū)域坐標(biāo)，首先在任意的單元格里用函數(shù)定義坐標(biāo)，分別代表數(shù)據(jù)復(fù)制源和黏貼點(diǎn)。然后將坐標(biāo)結(jié)合在相應(yīng)的工作表名稱上，通過C來復(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 "沒有找到！" & 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("合計").Row - 1 '尋找“合計”所在行-1 Rows(A).Copy '復(fù)制 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.該示例設(shè)定了增加、刪除行的限定范圍。 2.利用查找某行數(shù)值（“合計”）來定位復(fù)制或刪除的行數(shù)。 Sub 增加行二() On Error Resume Next '忽略錯誤 Dim r As Long '設(shè)置變量r r = ActiveCell.Row '將r定義為地前鼠標(biāo)所在行 If r > 3 Then '如果行數(shù)大于3執(zhí)行命令 Rows(r).Insert Shift:=xlDown '所在行向下移動 End If End Sub Change的運(yùn)用 ★ 在對話框里A輸入數(shù)字，對話框B同步顯示數(shù)字中文大寫 Private Sub TextBox3_Change() [I7] = Val(TextBox3) TextBox4.Value = [D7] End Sub 分析：首先將textbox3的值賦予“I7”單元格 單元格“D7”的內(nèi)容是中文轉(zhuǎn)換公式 將“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 ★對話框之間建立勾稽關(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ā)生變化時執(zhí)行程序： 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 按鈕的激活切換 ★凍結(jié)“確認(rèn)”按鈕（當(dāng)兩個對話框都有數(shù)據(jù)時恢復(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) = "合計" 在表尾添加“合計”標(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 對話框內(nèi)文字格式 MsgBox "××××××××", 1 + 64, "××××" 分析：以上是一個簡單的對話框，MsgBox “A”, B + C, “D” A：對話框文字 B：當(dāng)它是1的時候，出現(xiàn)“確定”、“取消”按鈕。 當(dāng)它是0的時候，出現(xiàn)“確定”按鈕。 當(dāng)它是2的時候，出現(xiàn)“終止”、“重試”、“忽略”按鈕 C：警示符號代碼：當(dāng)它是64的時候，出現(xiàn)“！”。當(dāng)它是32的時候，出現(xiàn)“？” 當(dāng)它是 16的時候，出現(xiàn)“×”。當(dāng)它是48的時候，出現(xiàn)“！” D：對話框標(biāo)題文字，如果沒有文字，則默認(rèn)為Microsoft Excel 注意：如果對話框文字較多，可以通過 &chr（10）& 進(jìn)行換行 示例： Sub輸入數(shù)值（） Dim x x=InputBox(“請輸入數(shù)據(jù)”, “A1中輸入數(shù)據(jù)”,100) Range(“A1”)=x End sub ★ 禁止在其他頁面時退出（使工作表右上角關(guān)閉按鈕無效） Private Sub Workbook_BeforeClose(Cancel As Boolean) If ActiveSheet.Name = "001" Then 如果當(dāng)前（活動）工作表名稱是001，那么： ActiveWorkbook.Save 保存活動工作簿 Else: Cancel = True 否則取消 MsgBox "請返回到首頁退出系統(tǒng)！", vbCritical, "幫助" End If End Sub ★ 防止對話框隱藏在后臺（使對話框右上角關(guān)閉按鈕無效） 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 '為組合框置項(xiàng)目 With ComboBox1 .List = myArray .ColumnCount = 2 .ColumnHeads = True .ListStyle = fmListStyleOption End With End Sub ②Private Sub UserForm_Initialize() '直接從數(shù)據(jù)庫提取，可以忽略單位名稱重復(fù) ComboBox1.Clear For i = 4 To Sheets("數(shù)據(jù)庫").[a65536].End(3).Row If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫").Range("a4:a" & i), Sheets("數(shù)據(jù)庫").Range("a" & i)) = 1 Then ComboBox1.AddItem Sheets("數(shù)據(jù)庫").Range("a" & i) End If Next i End Sub ③Private Sub UserForm_Initialize() '如果復(fù)制范圍固定并且簡單，可直接加上參數(shù) ComboBox1.Clear ComboBox1.List = Array("北京", "上海", "重慶", "深圳") End Sub ④Private Sub UserForm_Initialize() '同時設(shè)置ListBox的列寬 ListBox1.ColumnWidths = "60;70;60;180;60;140" ListBox1.RowSource = Sheet1.[C2] '設(shè)定ListBox的取值范圍（參考單元格C2里的公式） End Sub ★一個單位名稱錄入的對話框案例 Private Sub CommandButton1_Click() A = ComboBox1.Value Range("H3").Value = A 'ComboBox1.Value = "" 可以清空對話框值 Unload Me End Sub 分析：以上是點(diǎn)擊“確定”按鈕，將對話框的值賦予單元格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 "單位已存在，請重新輸入", , "提示" ComboBox1.Value = "" End If End Sub ★ 鼠標(biāo)單擊事件 Private Sub Worksheet_SelectionChange(ByVal Target As Range) '一個修改提醒代碼 If Target.Row < 8 Then Exit Sub '如果選中一個單元格行數(shù)小于8（限定于所需表格范圍） If Target.Count = 1 Then '如果只選中一個單元格（避免多行改動時也運(yùn)行下面的程序） If Target.Column = 2 Then '如果修改的是第2列（指定某列進(jìn)行操作） If Target.Text = "" Then '如果是空白單元格（只對空白單元格進(jìn)行程序，避免錯誤修改） Else MsgBox ("業(yè)務(wù)發(fā)生日期不能隨意更改") 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) '鼠標(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) '禁止對A1單元格進(jìn)行修改 If Target.Address = "$A$1" Then A = InputBox("請輸入密碼", "officefans") If A = 1 Then [A1].Select Else [A2].Select End If End Sub ★ 鼠標(biāo)雙擊事件，一個彈出對話框代碼 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)所在單元格為空值同時鼠標(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é)屏幕，以防屏幕抖動 Application.ScreenUpdating = False 路徑 = ThisWorkbook.Path & "\分表\" '把文件路徑定義給變量 數(shù)據(jù)源 = Dir(路徑 & "*.xls") '依次找尋指定路徑中的*.xls文件 Do While 數(shù)據(jù)源 <> "" '當(dāng)指定路徑中有文件時進(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 '找尋下一個*.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 '忽略錯誤繼續(xù)執(zhí)行VBA代碼,避免出現(xiàn)錯誤消息 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 命令條計數(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 ★ 一個最簡單的密碼登錄系統(tǒng) 先設(shè)置工作簿打開時執(zhí)行代碼： Private Sub Workbook_Open() Sheet2.Select '將表2設(shè)置成全空白 Application.Visible = False '關(guān)閉屏幕刷新 UserForm1.Show '彈出對話框1 End Sub 然后設(shè)置對話框“確認(rèn)”按鈕代碼： Private Sub CommandButton1_Click() A = TextBox1.Text If "888888" = A Then Application.Visible = True Sheet2.Select Unload Me Else MsgBox "密碼錯誤,系統(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)閉對話框 保護(hù)所有工作表 IF判斷用戶性質(zhì) 解除工作表保護(hù) ElseIf判斷其他用戶 保護(hù)所有工作表 Else End If Else 密碼錯誤即退出 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 '如果：核對用戶名及密碼是否匹配，那么 Application.Visible = True '取消工作表的隱藏 Unload Me '關(guān)閉對話框 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 "密碼錯誤,系統(tǒng)退出!", , "提示" Application.Visible = True Application.ScreenUpdating = True Application.Quit End If Application.ScreenUpdating = True End Sub ● 在A列查找并激活（自動上移） 說明：將要查找的數(shù)值錄入到“J1”單元格，如果A列里有符合的值，就Select。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$1" Then ’如果鼠標(biāo)地址是“J1”時 Range("a:a").Find(Target, , , xlWhole).Select ’在A列查找并激活 End If ’如果句結(jié)束 End Sub ● 光標(biāo)自動回到C列 說明：當(dāng)鼠標(biāo)點(diǎn)擊A列以外的區(qū)域，光標(biāo)回到C列。在這里設(shè)置了一個例外條件：當(dāng)A1單元格為“*”時，不執(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ù)值后，回車可以自動填充到B列里，并終止重復(fù)輸入 說明：這里設(shè)置了一個密碼解除和重新加密的步驟 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時，不執(zhí)行代碼 If Target = "" Then Exit Sub '為空值時，不執(zhí)行代碼 If Application.CountIf(Range("B7:B" & i), Range("E2")) = 0 Then '當(dāng)計算B列的值不重復(fù)于E2的值時 '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 & "”已存在，請重新輸入", , "提示" Target = "" End If End Sub ● 數(shù)據(jù)篩選 說明：這里的:="*" & [e3] & "*"是篩選條件，而且采用了通配符*加數(shù)值的結(jié)合。如果將它改成“*”，則視為對非空白單元格的篩選。 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 ● 限定值 說明：★限定了執(zhí)行區(qū)域，避免整個工作表都被限定值 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,請新輸入!!!", 0 + 48 Application.EnableEvents = False Target = "" Application.EnableEvents = True End If End If End Sub ● 凍結(jié)窗口的操作 說明：以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 ● 自動篩選及解除篩選 Sub 篩選 () ActiveSheet.Unprotect Password:="123456789" 解除工作表密碼 Selection.AutoFilter Field:=2, Criteria1:="1" 對第二列進(jìn)行自動篩選，篩選標(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 ● 兩個區(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 & _ "對換后數(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 "選擇的兩個區(qū)域不相同！" End If Else MsgBox "請選擇二個相同的區(qū)域！" End If End Sub ● 對話框選擇性按鈕樣式 If MsgBox(" " & Chr(10) & " ", vbYesNo, "提示") = vbYes Then End If 理解：這是一個典型的選擇yes和no的對話框，當(dāng)選擇no時終止程序繼續(xù)運(yùn)行。中間chr（10）是起到換行作用的，同時要注意以end if 作為結(jié)束句 示例： 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 理解：首先設(shè)置兩個變量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 '為組合框置項(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)在時刻: " & 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)選的單元格 ●在對話框里設(shè)置下拉框 Private Sub UserForm_Initialize() '加載列表框數(shù)據(jù) ComboBox1.Clear For i = 4 To Sheets("數(shù)據(jù)庫").[b65536].End(3).Row If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫").Range("b4:b" & i), Sheets("數(shù)據(jù)庫").Range("b" & i)) = 1 Then ComboBox1.AddItem Sheets("數(shù)據(jù)庫").Range("b" & i) End If Next i End Sub ■在工作表里添加3個下拉框 Private Sub CBox1() ComboBox1.Clear For i = 3 To Sheets("數(shù)據(jù)庫").[c65536].End(3).Row If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫").Range("c1:c" & i), Sheets("數(shù)據(jù)庫").Range("c" & i)) = 1 Then ComboBox1.AddItem Sheets("數(shù)據(jù)庫").Range("c" & i) End If Next i End Sub ******************* Private Sub CBox2() ComboBox2.Clear For i = 3 To Sheets("數(shù)據(jù)庫").[c65536].End(3).Row If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫").Range("c1:c" & i), Sheets("數(shù)據(jù)庫").Range("c" & i)) = 1 Then ComboBox2.AddItem Sheets("數(shù)據(jù)庫").Range("c" & i) End If Next i End Sub ******************** Private Sub CBox3() ComboBox3.Clear For i = 3 To Sheets("數(shù)據(jù)庫").[b65536].End(3).Row If WorksheetFunction.CountIf(Sheets("數(shù)據(jù)庫").Range("b1:b" & i), Sheets("數(shù)據(jù)庫").Range("b" & i)) = 1 Then ComboBox3.AddItem Sheets("數(shù)據(jù)庫").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)的浮動對話框（或按鈕） 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ù)制“模板”，并以對話框內(nèi)容命名 Private Sub CommandButton1_Click() If TextBox1.Text = "" Then MsgBox ("請?zhí)顚憜挝缓喎Q"): 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() '當(dāng)激活工作表時彈出對話框 UserForm1.Show End Sub ****************** Private Sub Worksheet_Deactivate() '工作表轉(zhuǎn)為非活動狀態(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 "對不起，您輸入的密碼錯誤, 您沒有權(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 ' 使對話框關(guān)閉按鈕無效 End Sub ■ 對話框居中動態(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 ■ 無邊框的對話框 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 ("該月沒有數(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）自動轉(zhuǎn)化成20110201以便查找該月份發(fā)生數(shù)據(jù)所在的行，這樣就可以動態(tài)的加載ListBox1數(shù)據(jù)了。 ****************** 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.更改標(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 '屏幕刷新功能啟動 9.工作表隱藏 Application.Visible = False Application.Visible = True 10.自動和手動計算 Application.Calculation = xlCalculationAutomatic '自動計算 Application.Calculation = xlCalculationManual '手動計算 11.更改狀態(tài)欄 Application.StatusBar = " " Application.StatusBar = vbNullString |
|
|
