EXCELVBA实用代码收集学习资料.docx
- 文档编号:15722005
- 上传时间:2023-07-07
- 格式:DOCX
- 页数:36
- 大小:24.37KB
EXCELVBA实用代码收集学习资料.docx
《EXCELVBA实用代码收集学习资料.docx》由会员分享,可在线阅读,更多相关《EXCELVBA实用代码收集学习资料.docx(36页珍藏版)》请在冰点文库上搜索。
EXCELVBA实用代码收集学习资料
EXCEL-VBA-实用代码收集
图片切换
Sub显示开或关()
IfActiveSheet.Shapes("Picture2").Visible=TrueThen
ActiveSheet.Shapes("Picture1").Visible=True
ActiveSheet.Shapes("Picture2").Visible=False
Else
ActiveSheet.Shapes("Picture2").Visible=True
ActiveSheet.Shapes("Picture1").Visible=False
EndIf
EndSub
当前单元格输入数字自动分解
PrivateSubWorksheet_Change(ByValTargetAsRange)
IfTarget.Column>1ThenExitSub
IfLen(Target(1,1))>1Then
DimoJsAsObject
SetoJs=CreateObject("ScriptControl"):
oJs.Language="JScript"
Target(1,2).Resize(1,254).ClearContents
Target.Resize(1,Len(Target))=Split(oJs.eval("'"&Target&"'.match(/./g);"),",")
EndIf
EndSub
word批量修改图片大小——固定长宽
Subsetpicsize()'设置图片大小
Dimn'图片个数
OnErrorResumeNext'忽略错误
Forn=1ToActiveDocument.InlineShapes.Count'InlineShapes类型图片
ActiveDocument.InlineShapes(n).Height=400'设置图片高度为400px
ActiveDocument.InlineShapes(n).Width=300'设置图片宽度300px
Nextn
Forn=1ToActiveDocument.Shapes.Count'Shapes类型图片
ActiveDocument.Shapes(n).Height=400'设置图片高度为400px
ActiveDocument.Shapes(n).Width=300'设置图片宽度300px
Nextn
EndSub
批量修改图片大小——按比例缩放篇
Subsetpicsize()'设置图片大小
Dimn'图片个数
Dimpicwidth
Dimpicheight
OnErrorResumeNext'忽略错误
Forn=1ToActiveDocument.InlineShapes.Count'InlineShapes类型图片
picheight=ActiveDocument.InlineShapes(n).Height
picwidth=ActiveDocument.InlineShapes(n).Width
ActiveDocument.InlineShapes(n).Height=picheight*1.1'设置高度为1.1倍
ActiveDocument.InlineShapes(n).Width=picwidth*1.1'设置宽度为1.1倍
Nextn
Forn=1To
ActiveDocument.Shapes.Count'Shapes类型图片
picheight=ActiveDocument.Shapes(n).Height
picwidth=ActiveDocument.Shapes(n).Width
ActiveDocument.Shapes(n).Height=picheight*1.1'设置高度为1.1倍
ActiveDocument.Shapes(n).Width=picwidth*1.1'设置宽度为1.1倍
Nextn
EndSub
批量给图片加边框
DimiAsInteger
Fori=1ToActiveDocument.InlineShapes.Count
WithActiveDocument.InlineShapes(i)
With.Borders(wdBorderLeft)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth100pt
.Color=wdColorAutomatic
EndWith
With.Borders(wdBorderRight)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth100pt
.Color=wdColorAutomatic
EndWith
With.Borders(wdBorderTop)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth100pt
.Color=wdColorAutomatic
EndWith
With.Borders(wdBorderBottom)
.LineStyle=wdLineStyleSingle
.LineWidth=wdLineWidth100pt
.Color=wdColorAutomatic
EndWith
.Borders.Shadow=False
EndWith
WithOptions
.DefaultBorderLineStyle=wdLineStyleSingle
.DefaultBorderLineWidth=wdLineWidth100pt
.DefaultBorderColor=wdColorAutomatic
EndWith
Nexti
锁定文件名
PrivateSubWorkbook_Open()
IfThisWorkbook.Name<>"三八节.xls"Then
Application.DisplayAlerts=False
Application.Quit
EndIf
EndSub
将数值转换为文本
[程序扩展]可以将程序代码1和程序代码2略加改动,将一个字符附加到所选单元格的开头。
如将cell.Value="'"&cell.Value换成cell.Value=”I”&cell.Value,则在所选单元格开头添加字符“I”,即可统一单元格开始形式。
[程序代码1]
Sub数值转换为文本1()'通过添加'号
DimcellAsRange
ForEachcellInSelection
IfNotcell.HasFormulaThen
IfNotIsEmpty(cell)Then
cell.Value="'"&cell.Value
EndIf
EndIf
Next
EndSub
[程序代码2]
Sub数值转换成文本2()'只对数字单元格进行操作
DimcellAsRange
ForEachcellInSelection
IfNotcell.HasFormulaThen
IfNotIsEmpty(cell)Then
IfIsNumeric(cell)Then
cell.Value="'"&cell.Value'可根据需要变换字符
EndIf
EndIf
EndIf
Next
EndSub
[程序代码3]
Sub数值转换为文本3()'通过格式
DimcellAsRange
ForEachcellInSelection
IfNotcell.HasFormulaThen
IfNotIsEmpty(cell)Then
Selection.NumberFormatLocal="@"
EndIf
EndIf
Next
EndSub
关闭并保存所有工作簿
OptionExplicit
SubCloseAllWorkbooks()
DimBookAsWorkbook
ForEachBookInWorkbooks
IfBook.Name<>ThisWorkbook.NameThen
Book.Closesavechanges:
=True
EndIf
NextBook
ThisWorkbook.Closesavechanges:
=True
EndSub
关闭工作簿并将它彻底删除
OptionExplicit
SubKillMe()
WithThisWorkbook
.Saved=True
.ChangeFileAccess
Mode:
=xlReadOnly
Kill.FullName.CloseFalse
EndWith
EndSub
A列输出排列组合
Subpailie()
DimsAsString,x()AsString
DimstarttimeAsSingle,endtimeAsSingle
DimiAsLong,jAsInteger,kAsInteger,NumAsLong,nAsInteger
DimALL(),TEMP1AsLong,TEMP2AsLong,arr()AsString
s=InputBox("请输入不重复的字母或数字")
n=Len(s)'元素个数
ReDimx(n-1)
Fori=1Ton
x(i-1)=Mid(s,i,1)
Next
starttime=Timer'开始计时
Num=1
Fori=1Ton
Num=Num*i '递归计算n!
Next
ReDimarr(1ToNum,1To1)
Fori=1ToNum
ReDimALL(1Ton)'初始化数组all
ALL
(1)=x(0)
TEMP1=i
Forj=2Ton
TEMP2=TEMP1Modj
TEMP1=TEMP1\j
IfTEMP2=0Then
ALL(j)=x(j-1)'temp2为0则放在最后
Else
Fork=jToTEMP2+1Step-1
ALL(k)=ALL(k-1) 'temp2之后的元素后移一位
Next
ALL(TEMP2)=x(j-1)'temp2不为0则置于第temp2个元素前
EndIf
Next
arr(i,1)=Join(ALL,"")'输出
Next
endtime=Timer
Application.ScreenUpdating=False
Range("a1").Resize(Num,1)=arr
Application.ScreenUpdating=True
MsgBox"共"&Num&"种排列!
用时"&endtime-starttime&"秒!
"
EndSub
同薄汇总工作表
Submysub()
Application.ScreenUpdating=False
DimshAsWorksheet,aaAsLong,bbAsLong,ccAsLong,ddAsLong
dd=Sheets("汇总").[IV1].End
(1).Column
Sheets("汇总").Range(Cells(2,2),Cells(65536,dd)).ClearContents
ForEachshInWorksheets
Ifsh.Name<>"汇总"Then
bb=Sheets("汇总").[b65536].End(xlUp).Row+1
aa=sh.[b65536].End(xlUp).Row
cc=sh.[IV1].End
(1).Column
sh.Range(sh.Cells(2,2),sh.Cells(aa,cc)).Copy
Sheets("汇总").Cells(bb,2).PasteSpecialxlPasteValues
EndIf
Nextsh
Application.ScreenUpdating=True
EndSub
异薄SHEET1汇总
PrivateSubCommandButton2_Click()
Application.ScreenUpdating=False
Dimi&,LastRow&,Path$,FileName$,TWB$,WBAsWorkbook
Path=ThisWorkbook.Path&"\"
FileName=Dir(Path&"*.xls")
TWB=ThisWorkbook.Name
Range("A1:
X65536").ClearContents
DoWhileLen(FileName)
IfFileName<>TWBThen
SetWB=Workbooks.Open(Path&FileName)
WithWB.Worksheets
(1)
LastRow=.Range("A65536").End(xlUp).Row
IfLastRow>1Then
.Range("A8:
x8").Copy
ThisWorkbook.Sheets("汇总").Range("A65536").End(xlUp)
(2).PasteSpecialPaste:
=xlValue
EndIf
EndWith
Application.CutCopyMode=False
WB.CloseTrue
EndIf
FileName=Dir()
Loop
Range("A1").Select
SetWB=Nothing
Application.ScreenUpdating=True
EndSub
异薄汇总工作表
PrivateSubCommandButton2_Click()
Application.ScreenUpdating=False
Dimi&,LastRow&,Path$,FileName$,TWB$,WSAsWorksheet,WBAsWorkbook
Path=ThisWorkbook.Path&"\"
FileName=Dir(Path&"*.xls")
TWB=ThisWorkbook.Name
Range("A1:
X65536").ClearContents
DoWhileLen(FileName)
IfFileName<>TWBThen
SetWB=Workbooks.Open(Path&FileName)
ForEachWSInWB.Worksheets
LastRow=WS.Range("A65536").End(xlUp).Row
IfLastRow>1Then
WS.Range("A8:
x"&LastRow).Copy'复制A8:
X列&最后有数据的列
ThisWorkbook.Sheets("汇总").Range("A65536").End(xlUp)
(2).PasteSpecialPaste:
=xlValue'粘贴到“汇总”表,从下往上数有数据的列的下一列
EndIf
Next
Application.CutCopyMode=False
WB.CloseTrue
EndIf
FileName=Dir()
Loop
Range("A1").Select
SetWB=Nothing
Application.ScreenUpdating=True
EndSub
调用实例
Application.Dialogs
(1).Show是调用打开对话框
Application.Dialogs(5或145).Show是调用另存为对话框,
Application.Dialogs(6).Show是删除文档
Application.Dialogs(7).Show是页面设置
Application.Dialogs(8).Show是打印对话框
Application.Dialogs(9).Show是选择打印机对话框
Application.Dialogs(12).Show是重排窗口设置对话框
Application.Dialogs(17).Show宏对话框
Application.Dialogs(23).Show设置打印标题
Application.Dialogs(26).Show字体设置对话框
Application.Dialogs(27).Show显示选项
Application.Dialogs(28).Show保护工作表
Application.Dialogs(32).Show重算选项
Application.Dialogs(39或192).Show排序
Application.Dialogs(40).Show序列选项
Application.Dialogs(41).Show模拟运算表
Application.Dialogs(42或111).Show单元格格式,选择单元格内容的格式
Application.Dialogs(43).Show选择单元格字体的排列格式,横排或竖排等
Application.Dialogs(44或134或190).Show字体选择
Application.Dialogs(45).Show边框格式设置
Application.Dialogs(46).Show对单元格的保护或隐藏选项
Application.Dialogs(47).Show列宽设置选项
Application.Dialogs(52).Show清除对话框
Application.Dialogs(53).Show选择性粘贴对话框
Application.Dialogs(54).Show删除对话框
Application.Dialogs(55).Show插入对话框
Application.Dialogs(61或110).Show定义名称对话框
Application.Dialogs(62).Show指定名称
Application.Dialogs(63或132).Show定位
Application.Dialogs(64).Show查找
Application.Dialogs(84).Show设置单元格颜色和图案
Application.Dialogs(91).Show分列
Application.Dialogs(94).Show取消或隐藏工作表选择对话框
Application.Dialogs(95).Show工作区视图等选项
Application.Dialogs(103).Show选择要激活哪个工作表对话框
Application.Dialogs(108).Show复制图片选项
Application.Dialogs(119).Show新建对话框
Application.Dialogs(127).Show设置行高
Application.Dialogs(130).Show替换对话框
Application.Dialogs(137).Show拆分当前窗口
Application.Dialogs(161).Show设置图表颜色
Application.Dialogs(170或171).Show移动当前窗口
Application.Dialogs(191).Show合并计算对话框
Application.Dialogs(198).Show单变量求解
Application.Dialogs(199).Show选定成组工作表
Application.Dialogs(200).Show填充成组工作表
选项按钮输入单元格
PrivateSubCommandButton1_Click()
ForEachspInMe.Frame1.Controls'在窗体(me)中的Frame1内的所有控件进行遍历
IfspThenSheet1.[a3]=sp.Caption'如果某个被选中,则将该选项按钮的Caption写入工作表Sheet1的a3单元格
Next
EndSub
PrivateSubUserForm_QueryClose(CancelAsInteger,CloseModeAsInteger)'1.直接关闭窗体应是不用保存的了(或给个提示,是否要保存)
IfMsgBox("是否保存选项",vbYesNo)=vbOKThen
ForEachspInMe.Frame1.Controls
CommandButton1_Click
Next
EndIf
EndSub
获取屏幕分辨率
Subfenbianlv()
strComputer="."
SetobjWMIService=GetObject("winmgmts:
"_
&"{impersonationLevel=impersonate}!
\\"&strComputer&"\root\cimv2")
SetcolSettings=objWMIService.ExecQuery_
("Select*fromWin32_DesktopMonitor")
ForEachobjScreen
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- EXCELVBA 实用 代码 收集 学习 资料