[A65536].End(xlUp).Row 'A
列末行向上第一个有值的行数
[A1].End(xlDown).Row 'A
列首行向下第一个有值之行数
[IV1].End(xlToLeft).Column '
第一行末列向左第一列有数值之列数。
[A1].End(xlToRight).Column '
第一行首列向右有连续值的末列之列数
Application.CommandBars("Standard").Controls(2).BeginGroup=True '
在常用工具栏的第二个按钮前插入分隔符
Cells.WrapText = False '
取消自动换行
If Len(Target) > 5 Then '
如果当前单元格中的字符数超过
5
个
,
执行下一行
Target.WrapText = True '
自动换行
End If
[A1:B10].SpecialCells(xlCellTypeBlanks).Rows.Hidden = True '
有空格即隐藏行
[A2].parent.name '
返回活动单元格的工作表名
[A2].parent.parent.name '
返回活动单元格的工作簿名
如下代码可使工作簿打开后
30
秒
(
或闲置
30
秒
)
内不输入、不重新选择等
,
自动关闭工作簿
Private Sub Workbook_Open() '
工作簿打开事件
tt '
工作簿打开时启动
tt
过程
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) '
工作表变化事件
tt '
工作表中任一单元格有变化时启动
tt
过程
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) '
工作表选择变化事件
tt '
工作表中单元格的选择有变化时启动
tt
过程
End Sub
Sub tt() 'tt
过程
Dim myNow As Date, BL As Integer '
定义
myNow
为日期型
;
定义
BL
为长整型
myNow = Now '
把当前的时间赋给变量
myNow
Do '
开始循环语句
Do
BL = Second(Now) - Second(myNow) '
循环中不断检查变量
BL
的值
If BL = 30 Then GoTo Cl '
当
BL=30
即跳转到
CL
DoEvents '
转让控制权
,
以便
sheets
可继续操作
Loop Until BL > 30 '
当
BL>30
即跳出循环
Exit Sub
Cl:
Application.EnableEvents = False '
避免引起其他事件
ActiveWorkbook.Close True '
关闭活动工作簿并保存
Application.EnableEvents = True '
可触发其他事件
End Sub
range("e4").addcomment.Text "
代头
" & Chr(10) & "
内容
……" '
添加批注
range("e4").Comment.Visible = True '
显示批注
把工作簿中所有工作表的指定列调整为最佳列宽：
Sub
调整列宽
()
Dim i%
For i = 1 To Sheets.Count '
遍历工作簿中所有的工作表
Sheets(i).Columns("A:K").AutoFit '
把每个工作表的
[A:K]
列调整为最佳列宽
Next i
End Sub
Do
循环语句的几种形式
:
1.
Do While i>1 '
条件为
True
时执行
... ... '
要执行的语句
Loop
2.
Do Until i>1 '
条件为
False
时执行
... ... '
要执行的语句
Loop
3.
Do
... ... '
要执行的语句
Loop While i>1 '
条件为
True
时执行
4.
Do
... ... '
要执行的语句
Loop Until i>1 '
条件为
False
时执行
5.While...Wend
语句
While i>1 '
条件为
True
时执行
... ... '
要执行的语句
Wend
勾选
"VBA
项目的信任
"
Application.SendKeys "%(tmstv){ENTER}" '
在
Excel
窗口操作
Application.SendKeys "%(qtmstv){ENTER}" '
在
VBE
窗口操作
Application.CommandBars("
命令按钮名称
").Position = msoBarFloating '
使
[
命令按钮
]
悬浮在表格中
Application.CommandBars("
命令按钮名称
").Position = msoBarTop '
使
[
命令按钮
]
排列在工具栏中
ActiveSheet.protect Password:="wshzw" '
为工作表保护加口令
ActiveSheet.Unprotect Password:="wshzw" '
解除工作表保护
Activesheet.ProtectContents '
判断工作表是否处于保护状态
工作表的复制与命名
Sub wshzw()
Dim i As Integer
For i = 1 To 5
Sheets("Sheet1").Copy After:=Sheets(1) 'Before/After
复制新表在
Sheets("Sheet1")
前
/
后
ActiveSheet.Name = i & "
月
" '
为复制的新表命名
Next i
Sheets("Sheet1").Name = "
总表
" '
为
Sheets("Sheet1")
改名
End Sub
Application.EnableEvents = False
......
Application.EnableEvents = True '
抑制事件连锁执行
Application.EnableEvents = False
ActiveWorkbook.Save '
抑制
BeforeSave
事件的发生
Application.EnableEvents = True '
抑制指定事件
Application.DisplayAlerts=False '
屏蔽确认提示
Application.ScreenUpdating = False
.......
Application.ScreenUpdating = true '
冻结屏幕以加快程序运行
ActiveCell.CurrentRegion.Select '
选择与活动单元格相连的区域
range("a2:a20").NumberFormatLocal = "00-00" '
区域的格式化
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '
已用区域的最末行
ActiveSheet.Copy Before:=Sheets(1) '
复制活动工作表到第一张工作表之前
range("a2:a20").FormulaHidden = True '
工作表处于保护状态时隐藏部分单元格公式
FileDateTime("E:"My Documents"33.xls")
或
FileDateTime(thisworkbook.FullName) '
文件被创建或最后修改后的日期和时间
FileLen(thisworkbook.FullName) / 1024
或
FileLen("E:"My Documents"temp"33.xls") / 1024 '
文件的长度
(
大小
),
单位是
KB
Application.AskToUpdateLinks = False '
不询问是否更新链接
,
并自动更新链接
ActiveSheet.Hyperlinks.Delete '
删除活动工作表超链接
ActiveWorkbook.SaveLinkValues = False '
不保存活动工作簿的外部链接值
ActiveSheet.PageSetup.CenterFooter = Range("k2").Value '
打印时设置自定义页脚
ActiveSheet.PageSetup.Orientation = xlLandscape '
设置为横向打印
ActiveSheet.PageSetup.Orientation = xlPortrait '
设置为纵向打印
Application.WindowState = xlMinimized '
最小化窗口
Application.WindowState = xlNormal '
最大化窗口
Sub
删除工作表
()
Application.DisplayAlerts = False
Sheet1.Delete
Application.DisplayAlerts = True
End Sub
有删除就有添加
Sub
添加工作表
()
For i = 1 To 5
Worksheets.Add.Name = i
Next
End Sub
[A1:A20].AdvancedFilter xlFilterCopy, [B1], Unique:=True '
可去掉重复数据
[A2:C32].Replace What:="F", Replacement:="G" '
指定范围内的查找与替换
Activesheet.AutoFilterMode = false '
取消自动筛选
执行以下语句可有效缩小工作簿的大小，执行前请先看清每条语句的作用
:
ActiveSheet.UsedRange.ClearComments '
清除活动工作表已使用范围所有批注
ActiveSheet.UsedRange.ClearFormats '
清除活动工作表已使用范围所有格式
ActiveSheet.UsedRange.Validation.Delete '
取消活动工作表已使用范围的数据有效性
ActiveSheet.Hyperlinks.Delete '
删除活动工作表超链接
ActiveSheet.DrawingObjects.Delete '
删除活动工作表已使用范围的所有对象
ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value '
取消活动工作表已使用范围的公式并保留值
还有：
Sub x()
Dim myRange As String
myRange = ActiveSheet.UsedRange.Address '
去除活动工作表无数据的行列
End Sub
ActiveWorkbook.FullName '
当前窗口文件名与路径
Application.AltStartupPath= "E:"My"MyStart" '
替补启动目录路径
Application.AutoRecover.Path '
返回
/
设置
Excel
存储
"
自动恢复
"
临时文件的完整路径
Application.DefaultFilePath '
选项
>
常规中的默认工作目录
Application.Evaluate("=INFO(""directory"")") '
默认工作目录
Application.LibraryPath '
返回库文件夹的路径
Application.NetworkTemplatesPath '
返回保存模板的网络路径
Application.Path '
返回应用程序完整路径
Application.RecentFiles.Item(1).Path '
返回最近使用的某个文件路径
,Item(1)=
第一个文件
Application.StartupPath 'Excel
启动文件夹的路径
Application.TemplatesPath '
返回模板所存储的本地路径
Application.UserLibraryPath '
返回用户计算机上
COM
加载宏的安装路径
Debug.Print Application.PathSeparator '
路径分隔符
"""
CurDir '
默认工作目录
Excel.Parent.DefaultFilePath '
默认工作目录
ThisWorkbook.Path '
返回当前工作薄的路径
dim mm(2,10)
Range("a1:b10")=mm '
可以将二维数组赋值给
Range
Application.Dialogs(XLdialogsaveas).show
显示保存对话框
[SIZE=1]Sub x()
Dim myRange As String
myRange = ActiveSheet.UsedRange.Address '
去除活动工作表无数据的行列
End Sub
这相当于把新的已使用区域赋值给变量，效果等同于手工删除多余的列或行后立即保存
;
来一个函数的
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
右边单元格反向显示活动单元格文本
If ActiveCell.Column < 256 Then ActiveCell.Offset(0, 1) = StrReverse(ActiveCell)
End Sub
想不到
UsedRange
还可以这样用，又学到了！有了这个就可以轻松取得当前
Sheet
的最末行和最末列号了：
Sub test()
Dim myRange As String
myRange = ActiveSheet.UsedRange.Address
Debug.Print "LastRow=" & Cells.SpecialCells(xlCellTypeLastCell).Row
Debug.Print "LastColumn=" & Cells.SpecialCells(xlCellTypeLastCell).Column
myRange = ""
End Sub
跟一帖：如上下相邻单元格数据相同则删除一个
Sub Yjue()
Dim myCell As Range, NCell As Range '
定义
Set myCell = ActiveSheet.Range("b2") '
把对象
ActiveSheet.Range("b2")
赋给变量
myCell
Do While Not IsEmpty(myCell) '
条件为
True
时执行
Set NCell = myCell.Offset(1, 0) '
把对象
myCell
的下一个单元格赋给变量
NCell
If NCell.Value = myCell.Value Then '
如上下相邻单元格数据相同
,
则望下执行
myCell.Delete '
删除
myCell
End If '
结束条件语句
Set myCell = NCell '
把变量
NCell
赋给变量
myCell,
等于在循环中把原
myCell
下移了一格
Loop
End Sub
复制行高列宽与内容
:
Sub Yjue() '
过程的名称
Sheet2.Rows("2:23").Copy '
复制行区域
Sheet3.Select '
选择粘贴区域
Range("A2").PasteSpecial Paste:=xlPasteColumnWidths '
粘贴类型
ActiveSheet.Paste '
实施粘贴
Application.CutCopyMode = False '
取消复制模式
End Sub
如整行为空白则删除整行
:
Sub DelRow()
Dim i As Integer, LastRow As Integer
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row '
把最后行的行号赋给变量
For i = LastRow To 1 Step -1 '
倒循环
If Range("iv" & i).End(xlToLeft).Column = 1 And Range("a" & i) = "" Then
Range("a" & i).EntireRow.Delete '
如整行为空白则删除整行
End If
Next i
End Sub
T = Application.GetOpenFilename("Text Files (*.dat), *.dat")
选择文件保存路径
通过依次赋色给单元格的例子，展示简单的
On Error GoTo Line1
用法：
Sub Yjue() '
过程名
Dim i As Integer '
定义
i
为整型
On Error GoTo Line1 '
遇到错误跳转到
Line1
For i = 0 To 65 '
予设从
0
循环到
65
Cells(i + 1, 2).Interior.ColorIndex = i '
依次赋色给第
2
列的单元格
Cells(i + 1, 1) = i '
依次给第
1
列的单元格标上色索引号
Next i
Exit Sub '
退出过程
Line1: '
遇到错误跳转到这行继续执行
MsgBox "
默认颜色只有
" & i - 1 & "
种。
" '
提示对话框
End Sub '
结束过程
通过显示或取消网格线，展示运算符
“Not”
应用的简单示例：
Dim myLine As Boolean '
定义变量
myLine
为布尔型
With CommandButton1 'With
语句结构
If .Caption = "
取消网格线
" Then '
如按钮上显示为
"
取消网格线
"
.Caption = "
显示网格线
" '
改按钮上的字幕为
"
显示网格线
"
myLine = ActiveWindow.DisplayGridlines '
把活动窗口当前网格线的显示状态赋给变量
ActiveWindow.DisplayGridlines = Not myLine '
进行逻辑否定运算
Else
.Caption = "
取消网格线
" '
否则按钮上显示为
"
取消网格线
"
ActiveWindow.DisplayGridlines = Not myLine '
进行逻辑否定运算
End If
End With '
结束
With
语句结构
ActiveCell.Offset(, -1).Name = "hzw" '
定义名称
ActiveCell.Precedents.Address '
被当前单元格所引用的区域地址
ActiveCell.Resize(0, 2).Select '
选定当前单元格并向右延伸二格
Activesheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 '
显示自动筛选后的行数
有选择地删除指定区域内的单元格
点击按钮可选择性的删除
[A1
：
A20]
区域内含有
[D1]
中字样的单元格；再点击按钮可返回原样；
如果替换了
[D1]
中的字样，点击按钮后所删除
[A1
：
A20]
区域中的单元格亦会随着变化。
With CommandButton1
If .Caption = "
删除单元格
" Then '
如按钮显示的字符为
:"
删除单元格
",
.Caption = "
反悔删除
" '
则改为
:"
反悔删除
"
For i = 20 To 1 Step -1 '
倒循环
If Cells(i, 1) Like "*" & Range("d1") & "*" Then
Cells(i, 1).Delete Shift:=xlUp '
如循环中发现某个单元格含有
[D1]
中字符
,
则删除该单元格
End If
Next i
Else
.Caption = "
删除单元格
" '
否则让按钮显示的字符为
:"
删除单元格
"
Range("a1:a20") = Range("f1:f20").Value '
把
[F1:F20]
赋给
[A1:A20],
为了可反复测试
End If
End With
下面换个话题，举一个限制鼠标只能在
[B2:G60]
以外的区域活动的例子：
With ActiveSheet 'With
语句
,
在一个单一对象上执行一系列的语句
.Unprotect '
解除没设密码的工作表保护
.Cells.Locked = False '
解除活动工作表中所有单元格的
“
锁定
”
.Range("b2:g60").Locked = True '
只锁定
[B2:G60]
区域
.EnableSelection = xlUnlockedCells '
仅允许选定未被有效锁定的单元格
.Protect '
工作表保护
(
没设密码
)
End With 'With
语句结束
一个复制数据后，只能粘贴数值的例子
Private Sub Worksheet_SelectionChange(ByVal T As Range) '
工作表
SelectionChange
事件
On Error Resume Next '
忽略代码运行中的错误
,
并越过错误继续执行后面的语句
If T.Column = 1 Then '
如活动单元格为第一列时执行下面的语句
Selection.PasteSpecial Paste:=xlPasteValues '
粘贴数值
Application.CutCopyMode = False '
立即清空剪贴板
End If 'IF
结构结束
End Sub '
本过程结束
-----------------------------------------------------------
如何用
VBA
获得工作簿名称
?
For Each wbk In Workbooks
MsgBox wbk.Name
Next
Workbooks.Close '
关闭所有工作簿
Application.Quit '
关闭所有工作簿
转载于:https://www.cnblogs.com/Anlycp/archive/2008/09/22/1296170.html
1697
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
