超好用宏的标准程序块.docx
- 文档编号:30296095
- 上传时间:2023-08-13
- 格式:DOCX
- 页数:29
- 大小:21.25KB
超好用宏的标准程序块.docx
《超好用宏的标准程序块.docx》由会员分享,可在线阅读,更多相关《超好用宏的标准程序块.docx(29页珍藏版)》请在冰豆网上搜索。
超好用宏的标准程序块
sub重新命名工作表()
sheets("sheet1").name="标准件计划"'选中sheet1文件簿,命名为“标准件计划”
endsub
sub新建工作表并命名()
sheets.add.name="标准件计划"'新建文件簿,命名为“标准件计划”
endsub
sub新建工作表自动命名()
sheets.add'新建文件簿,自动命名
endsub
sub插入行()
rows("1:
1").select'选中第一行
selection.insertshift:
=xldown'插入行
endsub
sub插入列()
selection.insertshift:
=xltoright'插入列
endsub
sub选中列()
columns("g:
g")'选中"g:
g"列,注:
需更改列数
endsub
sub选中工作表()
sheets("标准件计划").select'选中文件簿,注:
需更改文件簿名称
endsub
sub选中单元格()
range("A2").select'选中单元格,注:
需更改单元格
endsub
sub选中单元格区域()
range("A2:
C20").select'选中单元格,注:
需更改单元格
endsub
sub选中单元格并赋值()
range("A2").select'选中单元格,注:
需更改单元格
Activecell.formular1c1="序号"'激活单元格,并赋值
endsub
sub选择性粘贴()
range("A2").select'1、选中单元格,注:
需更改单元格
selection.copy'复制选中的对象
range("A3").select'1、选中单元格,注:
需更改单元格
selection.pasteSpecialPaste:
=xlpasteValues,operation:
=xlNone,SkipBlanks_
:
=False,Transpose:
=False'选择性粘贴,注:
此处“_”为换行符号,为空格+_
endsub
sub粘贴()
Cells.select'选中所有单元格,注:
需更改单元格
selection.copy'复制选中的对象
sheets("标准件计划").select'选中文件簿,注:
需更改文件簿名称
Cells.select'选中所有单元格,注:
需更改单元格
Activesheet.paste'粘贴
endsub
sub删除选中列()
columns("A:
F").AdvancedFilterAction:
=xlFilterCopy,criteriaRange:
=Sheets(_
"条件区").Rows("1:
2"),CopyToRange:
=Range("G1"),Unique:
=False'"A:
F"中数据_
按"条件区"中"1:
2"行条件进行高级筛选,筛选后的数据粘贴在单元格"G1"起的数据区_
内。
注:
1、"A:
F"数据区中1行应有分项名,如“日期”、“品名”“单价”等,同理_
"1:
2"条件区1行也应有分项名。
2、此处"条件区"为可变,以实际应用的文件簿为准。
_
3、此处"G1"为可变量,具体以放在哪里合适为准,应该是"A:
F"以后列。
4、此处_
columns("A:
F")、Rows("1:
2")都可以为单元格。
columns("A:
F").Select'选中A至F列
selection.DeleteShift:
=xlToLeft'删除选中列
endsub
sub单元格内字各个符颜色和格式()
range("A1").select'选中单元格“A1”
withactivecell.characters(start:
=1,length:
=4).Font'激活单元格的字体特性_
(第1个字符开始,长度为4个;1和4是变量)
.name="仿宋"'字体名字
.fontstyle="加粗"'字体风格
.size=9'字体大小
.strikethrough=false'删除线
.superscript=false'上标
.outlineFont=false'字体外形
.shadow=false'字体外形
.underline=xlUnderlineStyleNone'无下划线
.ColorIndex=xlAutomatic'颜色为自动
endwith'以。
。
。
。
结束
endsub
submacr16()
fori=1to10'i为1至10
cells(i,i).value=i'单元格(i,i)的值等于i
nexti'下一个i值循环
endsub
submacr17()
fori=2to10'i为2至10
ifcells(i,6).value>0then'如果单元格(i,6)的值大于0,那么
cells(i,8).value="servicerevenue"'单元格(i,8)的赋值为“维修收入”
cells(i,1).resize(1,8).interior.colorindex=4'单元格(i,1),单元格调_
整到“第1至第8格”,颜色外壳(单元格底色)=4(绿色)。
(其中cells(i,1)的_
1作为单元格列数起点,resize(1,8)中的1受前面到限制。
)
endif'终止如果函数
nexti'下一个i值循环
endsub
submacr18()
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号到行才是有效到数据集,才进行以下运算。
fori=2tofinalrow'i为2至finalrow,“finalrow”为变量
ifcells(i,6).value>0then'如果单元格(i,6)的值大于0,那么
cells(i,8).value="servicerevenue"'单元格(i,8)的赋值为“维修收入”
cells(i,1).resize(1,8).interior.colorindex=4'单元格(i,1),单元格调_
整到“第1至第8格”,颜色外壳(单元格底色)=4(绿色)。
(其中cells(i,1)的_
1作为单元格列数起点,resize(1,8)中的1受前面到限制。
)
endif'终止如果函数
nexti'下一个i值循环
endsub
sub变量选择多行数据()
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号到行才是有效到数据集,才进行以下运算。
i=finalrow'ifinalrow,“finalrow”为变量
range(cells(1,1),cells(i,256)).select'选中所有数据
selection.cut'剪切选中所有数据
endsub
submacr19()
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号的行才是有效到数据集,才进行以下运算。
fori=2tofinalrowstep2'i为2至finalrow,“finalrow”为变量,“step2"_
幅度为2(每两个计算一次,“2”可以为任意值)。
cells(i,1).resize(1,8).interior.colorindex=4'单元格(i,1),单元格调_
整到“第1至第8格”,颜色外壳(单元格底色)=4(绿色)。
(其中cells(i,1)的_
1作为单元格列数起点,resize(1,8)中的1受前面到限制。
)
nexti'下一个i值循环
endsub
sub删除符合条件的行()
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号的行才是有效到数据集,才进行以下运算。
fori=finalrowto2step-1'i为2至finalrow,“finalrow”为变量,“step-1"_
幅度为1(让For....Next循环从高向低运行)。
ifcells(i,1).value>0then'如果单元格(i,1)大于0那么
cells(i,1).Entirerow.Copy'单元格(i,1)整个行复制
sheets("费用总计表").select
rows("1:
1").select'选中1行
selection.insertshift:
=xldown'插入复制单元格
Wsd.select'选中文件簿1
endif
nexti'下一个i值循环
endsub
submacr23()
DimkAsinteger'定义k为整数类型
fork=1to137'定义k为1至137
worksheets(k).select'选中文件簿k
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号的行才是有效到数据集,才进行以下运算。
fori=finalrowto2step-1'i为2至finalrow,“finalrow”为变量,“step-1"_
幅度为1(让For....Next循环从高向低运行)。
ifcells(i,1).value>0then'如果单元格(i,1)大于0那么
cells(i,1).Entirerow.Copy'单元格(i,1)整个行复制
sheets("费用总计表").select
rows("1:
1").select'选中1行
selection.insertshift:
=xldown'插入复制单元格
worksheets(k).select'选中文件簿k
endif
nexti'下一个i值循环
nextk'下一个k值循环
endsub
submacr24()
'使用If...Then...Else...EndIf
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号的行才是有效到数据集,才进行以下运算。
fori=2tofinalrow
ifcells(i,1).value="及格"then'如果单元格(i,1)等于"及格"那么
cells(i,1).resize(1,3).font.colorindex=4'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=4(绿色)。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
Else
cells(i,1).resize(1,3).font.colorindex=50'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=50(绿色)。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
endif
nexti'下一个i值循环
endsub
submacr25()
'使用If...ElseIF...ElseIF...Else....EndIf
finalrow=cells(65536,1).end(xlup).row'最后行等于A列单元格不是空白为止,_
实际运用中A列一般为序号,那么就是有序号的行才是有效到数据集,才进行以下运算。
fori=2tofinalrow
ifcells(i,1).value="及格"then'如果单元格(i,1)等于"及格"那么
cells(i,1).resize(1,3).font.colorindex=3'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=3。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
Elseifcells(i,1).value="不及格"then'如果单元格(i,1)等于"及格"那么
cells(i,1).resize(1,3).font.colorindex=50'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=50。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
Elseifcells(i,1).value="优秀"then'如果单元格(i,1)等于"及格"那么
cells(i,1).resize(1,3).font.colorindex=5'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=5。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
Else
cells(i,1).resize(1,3).font.colorindex=6'单元格(i,1),单元格调_
整到“第1至第3格”,字体颜色=50(绿色)。
(其中cells(i,1)的1作为单元格列数起_
点,resize(1,3)中的1受前面到限制。
)
endif
nexti'下一个i值循环
endsub
submacr26()
range("b2:
cv100").formular1c1="=rc1*r1c"'乘法表,A1、B1、C1......乘以1A、_
2A、3A、......
endsub
Function指定名字()AsString'设置用户自定义函数“指定名字”,指定单元格内_
容为该单元格所在文件簿的名字。
注:
使用时直接到用户自定义函数中提出。
注:
函数_
名字都中英皆可。
指定名字=thisworkbook.Name
endFunction
Function指定路径()AsString'设置用户自定义函数“指定路径”,指定单元格内_
容为该单元格所在文件簿的名字。
注:
使用时直接到用户自定义函数中提出。
注:
函数_
名字都中英皆可。
指定路径=thisworkbook.FullName
endFunction
Function上次保存时间(文件路径AsString)AsDate'设置用户自定义函数“上次_
保存时间”,参数为文件路径。
注:
函数名字都中英皆可。
上次保存时间=FileDateTime(文件路径)
endFunction
Function现在时间'设置设置文件当前时间,不手动更新返回单元格的话,会不变化_
设置时间。
注:
函数名字都中英皆可。
现在时间=Now
endFunction
Sub合并内容相同的连续单元格()
DimIntRowAsInteger
DimiAsInteger
Application.DisplayAlerts=False
WithSheet1
IntRow=.Range("A65536").End(xlUp).Row
Fori=IntRowTo2Step-1
If.Cells(i,2).Value=.Cells(i-1,2).ValueThen
.Range(.Cells(i-1,2),.Cells(i,2)).Merge
EndIf
Next
EndWith
Application.DisplayAlerts=True
EndSub'解析:
第7行到第11行代码,从最后一行开始,向上逐个单元格判断连续两_
个单元格的内容是否相同,如果相同则合并。
运行Mergerng过程后,结果如图所示。
Sub取消合并单元格时在每个单元格中保留内容()
DimStrMerAsString
DimIntCotAsInteger
DimiAsInteger
WithSheet1
Fori=2To.Range("B65536").End(xlUp).Row
StrMer=.Cells(i,2).Value
IntCot=.Cells(i,2).MergeArea.Count
.Cells(i,2).UnMerge
.Range(.Cells(i,2),.Cells(i+IntCot-1,2)).Value=StrMer
i=i+IntCot-1
Next
EndWith
EndSub'解析:
UnMerge过程取消工作表中B列中的合并单元格,并且各个单元格均保留_
原合并单元格的内容。
第7行代码取得B列每个合并单元格的内容。
第8行代码取得合并区_
域的单元格数量。
第9行代码使用UnMerge方法取消合并单元格。
UnMerge方法将合并区域_
分解为独立的单元格,语法如下:
expression.UnMerge第10行代码将原合并单元格的内容_
赋值给取消合并单元格后的区域。
第11行代码调整循环变量i的值,使下一次循环从下一_
个单元格区域开始。
Sub预算表头()
DimiAsInteger
DimkAsInteger
i=ActiveCell.Row'获取单元格区域Rng左上角单元格所在行编号
k=ActiveCell.Column'获取单元格区域Rng左上角单元格所在列编号
Cells(i,k).FormulaR1C1="序号"'激活单元格,并赋值
Cells(i,k+1).FormulaR1C1="名称"'激活单元格,并赋值
Cells(i,k+2).FormulaR1C1="型号"'激活单元格,并赋值
Cells(i,k+3).FormulaR1C1="单位"'激活单元格,并赋值
Cells(i,k+4).FormulaR1C1="数量"'激活单元格,并赋值
Cells(i,k+5).FormulaR1C1="单价"'激活单元格,并赋值
Cells(i,k+6).FormulaR1C1="单重"'激活单元格,并赋值
Cells(i,k+7).FormulaR1C1="总价"'激活单元格,并赋值
Cells(i,k+8).FormulaR1C1="总价"'激活单元格,并赋值
Cells(i,k+9).FormulaR1C1="备注"'激活单元格,并赋值
Range(Cells(i,k),Cells(i,k+9)).Select'选中单元格
WithSelection.Font'单元格字体
.Name="宋体"
.Size=12
.Strikethrough=False
.Superscript=False
.Subscript=False
.OutlineFont=False
.Shadow=False
.Underline=xlUnderlineStyleNone
.ColorIndex=xlAutomatic
EndWith
WithSelection
.HorizontalAlignment=xlCenter
.VerticalAlignment=xlBottom
.WrapText=False
.Orientation=0
.AddIndent=False
.IndentLevel=0
.ShrinkToFit=False
.ReadingOrder=xlContext
.MergeCells=False
EndWith
Selection.Font.Bold=True
Selection.Font.ColorIndex=41'单元格字体颜色
EndSub
Sub合并内容相同的连续单元格()
DimIntRowAsInteger
DimiAsInteger
DimkAsInteger
Application.DisplayAlerts=False
k=ActiveCell.Column'获取单元格区域Rng左上角单元格所在列编号
WithActiveSheet'此处不是很懂,好像没什么用处,原来是sheet1也可以使用!
!
!
IntRow=.Cells(65536,k).End(xlUp).Row'提取最后一行行号,也可用.Range("A65536")
Fori=IntRowTo2Step-1
If.Cells(i,k).Value=.Cells(i-1,k).ValueThen
.Range(.Cells(i-1,k),.Cells(i,k)).Merge
EndIf
Next
EndWith
Application.DisplayAlerts=True
EndSub'解析:
第7行到第11行代码,从最后一行开始,向上逐个单元格判断连续两_
个单元格的内容是否相同,如果相同则合并。
运行Mergerng过程后,结果如图所示。
Sub取消合并单元格时在每个单元格中保留内容()
DimStrMerAsString
DimIntCotAsInteger
DimiAsInteger
DimkAsInteger
k=ActiveCell.Column'获取单元格区域Rng左上角单元格所在列编号
WithActiveSheet'此处不是很懂,好像没什么用处,原来是sheet1也可以使用!
!
!
Fori=2To.Cells(65536,k).End(xlUp).Row'提取最后一行行号,也可用.Range("A65536")
StrMer=.Cells(i,k).Value
IntCot=.Cells(i,k).MergeArea.Count
.Cells(i,k).UnMerge
.Range(.Cells(i,k),.Cells(i+IntCot-1,k)).Value=StrMer
i=i+IntCot-1
Next
EndWith
EndSub'解析:
UnMerge过程取消工作表中B列中的合并单元格,并且各个单元格均保留_
原合并单元格的内容。
第7行代码取得B列每个合并单元格的内容。
第8行代码取得合并区_
域的单元格数量。
第9行代码使用UnMerge方法取消合并单元格。
UnMerge方法将合并区域_
分解为独立的单元格,语法如下:
expre
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- 超好用宏 标准 程序