#标题#:EXCEL VB常用宏代码集
教你玩转EXCEL的VBA
阻止另存为命令的使用
本示例将阻止在工作簿中选择菜单“文件——另存为”命令的使用。当您选择“另存为”命令后，将会弹出一个消息框，告诉您不能使用另存为命令更改工作簿的名称。但您可以对该工作簿进行重命名。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lReply As Long
If SaveAsUI = True Then
lReply = MsgBox("对不起，您不能用其它名称保存本工作簿. ", vbQuestion + vbOKCancel)
Cancel = (lReply = vbCancel)
If Cancel = False Then Me.Save
Cancel = True
End If
End Sub
阻止用户打印工作簿
本示例演示当用户试图进行"打印预览"或"打印"时，将弹出不能打印本工作簿的消息框，因而不能对该工作簿进行打印预览或打印操作。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
Cancel = True
MsgBox "对不起，您不能打印本工作簿.", vbInformation
End Sub
阻止打印工作簿中的部分工作表
本程序将阻止用户打印工作簿中的部分工作表，即在这些工作表中(如工作表Sheet1和Sheet2)使用“打印预览”和”打印”功能时，将弹出不能打印的消息框。而可以对其它工作表进行正常的打印预览和打印操作。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
Select Case ActiveSheet.Name
Case "Sheet1", "Sheet2"
Cancel = True
MsgBox "对不起，您不能打印本工作簿中的这个工作表", vbInformation End Select
End Sub
阻止用户在工作簿中添加新工作表
本程序将阻止用户在新工作簿中添加新工作表，即当用户选择插入新工作表命令时，将会弹出不允许添加新工作表的消息框且不能添加新的工作表。
下面的代码放置在ThisWorkbook代码模块中：
‘*****************************************************
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.DisplayAlerts = False
MsgBox "对不起，您不能在本工作簿中添加新的工作表", vbInformation Sh.Delete
Application.DisplayAlerts = True
End Sub
将公式结果转换为值
本示例将由公式所产生的结果转换为数值，即按要求运行程序后，公式单元格区域将转换成数值。当您再编辑这些区域时，不会显示公式，而是数值。‘*****************************************************
Sub ValuesOnly()
Dim rRange As Range
On Error Resume Next
Set rRange = Application.InputBox(Prompt:="请选取公式单元格区域", _ Title:="转换为数值", Type:=8)
If rRange Is Nothing Then Exit Sub
rRange = rRange.Value
End Sub
几种从数据库读取数据生成excel文件的比较
以下是近段时间从不同地方收集到的一些学习资料，希望对新手有借鉴作用，同时感谢各位对我的支持和帮助，先发60小点，代码可能不完全正确，请指正. 全部显示
1,Application.CommandBars("Worksheet Menu Bar").Enabled = false
2,w,"b").value '活动单元格所在行B列单元格中的值3,Sub CheckSheet()'如果当前工作薄中没有名为kk的工作表的话，就增加一张名为kk的工作表，并将其排在工作表从左至右顺序排列的最左边的位置，即排在第一的位置
Dim shtSheet As Worksheet
For Each shtSheet In Sheets
If shtSheet.Name = "KK" Then Exit Sub
Next shtSheet
Set shtSheet = Sheets.Add(Before:=Sheets(1))
shtSheet.Name = "KK"
End Sub
4,Sheet1.ListBox1.List = Array("一月", "二月", "三月", "四月")'一次性增加项目
5,Sheet2.Rows(1).Value = Sheet1.Rows(1).Value'将一个表中的一行全部拷贝到另一个表中
6,Sub pro_cell()'将此代码放入sheet1，则me=sheet1，主要是认识me
Me.Unprotect
Cells.Locked = False
Range("D11:E11").Locked = True
Me.Protect
End Sub
7,Application.CommandBars("Ply").Enabled = False'工作表标签上快捷菜单失效
8,Sub aa()'把B1到B12单元格的数据填入c1到c12
For i = 1 To 12
Range("C" & i) = Range("B" & i)
Next i
End Sub
9,ActiveCell.AddComment
Selection.Font.Size = 12'在点选的单元格插入批注，字体为12号
10,Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
End Sub
11,ScrollArea 属性
参阅应用于示例特性以 A1 样式的区域引用形式返回或设置允许滚动的区域.用户不能选定滚动区域之外的单元格.String 类型，可读写.
说明
可将本属性设置为空字符串 ("") 以允许对整张工作表内所有单元格的选定.
示例
本示例设置第一张工作表的滚动区域.
Worksheets(1).ScrollArea = "a1:f10"
12\if application.max([a1:e1])=10 then
msgbox""
'A1—E1最大的数值达到10时，自动弹出对话框，并冻结按钮
12，本示例将更改的单元格的颜设为蓝.
Private Sub Worksheet_Change(ByVal Target as Range)
Target.Font.ColorIndex = 5
End Sub
13,Sub test()'求和
Dim rng As Range, rng2 As Range
For Each rng In ActiveSheet.UsedRange.Columns
Set rng2 = Range(Cells(1, rng.Column), Cells(Cells(65536,
rng.Column).End(xlUp).Row, rng.Column))
rng2.Cells(rng2.Cells.Count).Offset(1, 0) = WorksheetFunction.Sum(rng2)
Next rng
End Sub
14，将工作薄中的全部n张工作表都在sheet1中建上链接
Sub test2()
Dim Pt As Range
Dim i As Integer
With Sheet1
Set Pt = .Range("a1")
For i = 2 To ThisWorkbook.Worksheets.Count
.Hyperlinks.Add Anchor:=Pt, Address:="",
SubAddress:=Worksheets(i).Name & "!A1"
Set Pt = Pt.Offset(1, 0)
Next i
End With
End Sub
15，保存所有打开的工作簿，然后退出 Microsoft Excel.
For Each w In Application.Workbooks
w.Save
Next w
Application.Quit
16，让form标题栏上的关闭按钮失效
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode 1 Then Cancel = True
End Sub
17,Sub countsh()'获得工作表的总数
MsgBox Sheets.Count
End Sub
18,Sub IE()'打开个人网页
ActiveWorkbook.FollowHyperlink "about:blank"
SendKeys "{F4}ykk1976.anyp{ENTER}", True
End Sub
19,Sub delback()'一次性删除工作簿中所有工作表的背景
For Each shtSheet In Sheets
shtSheet.SetBackgroundPicture Filename:=""
Next shtSheet
End Sub
20,[a1].formula="=b1+c1"'A1中设定公式为=B1+C1
21,Private Sub CommandButton1_Click()'将A1到C6中大于=3的数依次放入E 列
Dim i As Long
r = 1
vb语言代码大全网页For Each i In Range("a1:c6")
If i > =3 Then Cells(r, 5) = i: r = r + 1
Next
End Sub
22,Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)'显示带数字的表名
b = Split(Sh.Name, "(")
On Error GoTo ss
num = CInt(Left(b(1), Len(b(1)) - 1))
If num >= 1 And num < 20 Then
MsgBox Sh.Name
End If
Exit Sub
ss:

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。