VBA代码汇总.docx
- 文档编号:6315990
- 上传时间:2023-01-05
- 格式:DOCX
- 页数:17
- 大小:18.59KB
VBA代码汇总.docx
《VBA代码汇总.docx》由会员分享,可在线阅读,更多相关《VBA代码汇总.docx(17页珍藏版)》请在冰豆网上搜索。
VBA代码汇总
Sub批量超链接word文档()
'宏1宏
'超链接
Dimp$,f$,iAsInteger
i=1
p="C:
\Users\Administrator\Desktop\国创撰写\"&""
f=Dir(p&"*.docx")'取得第一个pdf文件名
DoWhilef<>""'循环语句
ThisWorkbook.Activate
Sheets
(1).Cells(i,1).Value=f'Range("a1").Value=p&f
ActiveSheet.Hyperlinks.AddAnchor:
=Cells(i,2),Address:
=p&f,_
TextToDisplay:
=f
'MsgBoxp&f显示路径加文件名
f=Dir'第二个文件名
i=i+1
Loop
EndSub
PrivateSubCommandButton1_Click()随机选择器
Dima,b,c,dAsString
DimshuAsInteger
Dimarr(1To4)
shu=Int((4*Rnd)+1)
arr
(1)=TextBox1.Value
arr
(2)=TextBox2.Value
arr(3)=TextBox3.Value
arr(4)=TextBox4.Value
MsgBox"excel推荐你今天应该吃"&arr(shu)
EndSub
PrivateSubCommandButton2_Click()
UnloadMe
EndSub
Sub批量新建指定名称工作簿()
Application.DisplayAlerts=False
Fori=1To54'个数减一
DimRngAsString
DimabcAsRange
DimwbAsWorkbook
Dimwb1AsWorkbook
Setwb1=ThisWorkbook
WithActiveCell
Rng=.Value
Setabc=.Offset(1,0)
EndWith
DimaAsRange
DimbAsLong
b=0
ForEachaInRange("E:
E")
Ifa.Value=RngThen
b=b+1
EndIf
Next
ActiveCell.Offset(b,0).EntireRow.Select
Selection.InsertShift:
=xlDown
Selection.InsertShift:
=xlDown
abc.Select
Range("A1").EntireRow.Copyabc.Offset(b,-4)
Setwb=Workbooks.Add
'Filename:
=ThisWorkbook.Path&Application.PathSeparator&Rng&".xls"
wb1.Sheets
(1).Activate
abc.CurrentRegion.Copy
wb.Sheets
(1).Activate
wb.Sheets
(1).Paste
wb.SaveAs"C:
\Users\Administrator\Desktop\团队人员统计\"&Rng&".xlsx"'之前忘了保存了
wb.Close
wb1.Sheets
(1).Activate
abc.Offset(b+1,0).Select
Next
Application.DisplayAlerts=True
EndSub
Sub输入输出()
DimabcAsString
abc=InputBox("你想问什么","这是一个标题")
CallMsgBox("房主你最帅^^",0,"这是标题")
'加了括号一定要返回值,或者加call
'DimwbAsWorkbook
'Setwb=Workbooks.Add
'wb.SaveAsFilename:
=ThisWorkbook.Path&Application.PathSeparator&"woshi.xls"'搞定名称啦!
Sub自动分组打印6_Click()
Fori=1To35
DimRngAsString
DimabcAsRange
WithActiveCell
Rng=.Value
Setabc=.Offset(1,0)
EndWith
DimaAsRange
DimbAsInteger
b=0
ForEachaInRange("A:
A")
Ifa.Value=RngThen
b=b+1
EndIf
Next
'MsgBoxb
ActiveCell.Offset(b,0).EntireRow.Select
Selection.InsertShift:
=xlDown
Selection.InsertShift:
=xlDown
abc.Select
Worksheets("团队出勤").PageSetup.PrintArea=abc.CurrentRegion.Address
Worksheets("团队出勤").PrintOut
Range("a1").EntireRow.Copyabc.Offset(b,0)
abc.Offset(b+1,0).Select
Next
EndSub
PublicSub多个工作表复制汇总()
Dimp$,f$,z$,iAsInteger
DimwbAsWorksheet
Dimwb1AsWorkbook
DimrngAsRange
Application.ScreenUpdating=False
Setwb=ThisWorkbook.Worksheets
(1)
'p="D:
\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\"&""
f=Dir(ThisWorkbook.Path&"\*.xls")'取得第一个excel文件名
DoWhilef<>""'循环语句
Setrng=wb.Range("A1048576").End(xlUp).Offset(1,0)'‘Setwb1="D:
\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\"&f
z=ThisWorkbook.Path&"\"&f
Setwb1=GetObject(z)
wb1.Sheets
(2).Activate
Columns("Q:
Q").Select
Selection.AutoFilter'筛选已验证过没问题
ActiveSheet.Range("Q:
Q").AutoFilterField:
=1,Criteria1:
="发明申请"
Rows("2:
2").Select
Selection.InsertShift:
=xlDown
Range("a3").CurrentRegion.Copyrng
wb1.CloseFalse
'wb.Activate
'Setrng=wb.Worksheets
(1).Range("A1048576").End(xlUp).Offset(1,0)
'rng.PasteSpecialPaste:
=xlPasteValues
'Range("a1").Value=p&f
'MsgBoxp&f显示路径加文件名
f=Dir'第二个文件名
Loop
Application.ScreenUpdating=True
EndSub
Sub股票分类建立工作表()
Application.DisplayAlerts=False
DimRngAsString
DimabcAsRange
DimbAsInteger
DimaAsRange
DimshtAsWorksheet
Rng=Worksheets("沪深300成分股10年").Range("b2").Value
Setabc=Worksheets("沪深300成分股10年").Range("b2")
DoWhileRng<>""
b=0
ForEachaInRange("b:
b")
Ifa.Value=RngThen
b=b+1
EndIf
Next
Worksheets("沪深300成分股10年").Activate
abc.Offset(b,0).EntireRow.Select
Selection.InsertShift:
=xlDown
Setsht=Worksheets.Add
sht.Name=Rng
Worksheets("沪深300成分股10年").Activate
abc.CurrentRegion.Copysht.Range("a1")
Setabc=abc.Offset(b+1,0)
Rng=abc.Value
Loop
EndSub
Sub遍历工作表求偏度峰度
ForEachsheetInSheets
sheet.Select
ActiveSheet.Range("F1").Select
ActiveCell.FormulaR1C1="=LN(RC[-2]/RC[-1])"
Setrng=ActiveSheet.Range("A1048576").End(xlUp)
a=rng.Row
ActiveSheet.Range("F2").Select
ActiveCell.FormulaR1C1="=LN(RC[-2]/R[-1]C[-2])"
ActiveSheet.Range("F2").Select
Selection.AutoFillDestination:
=Range("F2:
F"&a)
ActiveSheet.Range("F2:
F"&a).Select
ActiveSheet.Range("G1").Select
ActiveCell.FormulaR1C1="=KURT(C[-1])"
ActiveSheet.Range("H1").Select
ActiveCell.FormulaR1C1="=SKEW(C[-2])"
Next
EndSub
Sub求单只股票每一年风度偏度()
'
Sub每年()
'
'每年宏
Dimrng,rng1,rng2AsRange
Dima,c,e,dAsString
DimsheetAsWorksheet
Dimb,i,fAsLong
Application.ScreenUpdating=false
ForEachsheetInSheets
sheet.Select
'选中活动工作表
‘k=ActiveSheet.Range("A1").CurrentRegion.Rows.Count‘取得最后一行的行号k为long
Setrng=ActiveSheet.Range("A1048576").End(xlUp)'获得最后一个非空单元格
a=rng.Row'非空单元格的行号
ActiveSheet.Range("j1").Select
ActiveCell.FormulaR1C1="=TEXT(RC[-7],""yyyy"")"'j1输入文本
Range("J1").Select
Selection.AutoFillDestination:
=Range("J1:
J"&a)'自动填充所有行
Setrng1=ActiveSheet.Range("j1")
i=1
DoWhilerng1<>""
c=rng1.Row
b=0
ForEachrng2InRange("j:
j")
Ifrng2.Value=rng1.valueThen
b=b+1
EndIf
Next'获得每一年的个数
d=rng1.Offset(b-1,0).Row
e=rng1.Value
ActiveSheet.Cells(i,11).Value=e
ActiveSheet.Cells(i,12).Value=Application.WorksheetFunction.Kurt(sheet.Range("F"&c&":
F"&d))
ActiveSheet.Cells(i,13).Value=Application.WorksheetFunction.Skew(sheet.Range("F"&c&":
F"&d))'计算
i=i+1
Setrng1=rng1.Offset(b,0)
Loop
next
Application.ScreenUpdating=True
-探戈写的代码:
Subtest2()
DimFilenameAsString,wbAsWorkbook,ErowAsLong,fnAsString,bjAsVariant,iAsLong,kAsLong,jAsLong,lAsLong
Filename=Dir(ThisWorkbook.Path&"\*.xls")
DoWhileFilename<>""
IfFilename<>ThisWorkbook.NameThen
fn=ThisWorkbook.Path&"\"&Filename
Workbooks.Open(fn)
WithActiveWorkbook.Worksheets
(1)
Cells(65536,"A").End(xlUp).EntireRow.Delete
Erow=Cells(65536,"C").End(xlUp).Row
Cells(3,"F").FormulaR1C1="=Year(RC[-3])"
Cells(3,"F").AutoFillDestination:
=Range(Cells(3,"F"),Cells(Erow,"F"))
Cells(1,"G")="年份"
Cells(1,"H")="峰度"
Cells(1,"I")="偏度"
i=3
l=3
bj=Cells(i,"F").Value
k=2007
j=3
DoWhilek<>2018
DoWhilebj=k
bj=Cells(i,"F").Value
i=i+1
Loop
Cells(j,"H").Formula="=KURT(R"&l&"C5:
R"&i&"C5)"
Cells(j,"I").Formula="=SKEW(R"&l&"C5:
R"&i&"C5)"
Cells(j,"G").Value=k
l=i+1
k=k+1
j=j+1
Loop
EndWith
ActiveWorkbook.Closesavechanges:
=True
EndIf
Filename=Dir
Loop
EndSub
使用cells.formula调用工作表函数
Cells(1,1).Formula="=sum(d"&l&":
d3)"
Sub计算个股(单个工作簿工作表)的收益率和偏度峰度a()
'
Sub计算偏度峰度a()
'
'每年宏
Dimrng,rng1,rng2,rng3AsRange
Dima,c,e,dAsString
DimsheetAsWorksheet
Dimb,i,f,kAsLong
Dimfilename,fnAsString
filename=Dir(ThisWorkbook.Path&"\*.xls")
Application.ScreenUpdating=False
DoWhilefilename<>""
Iffilename<>ThisWorkbook.NameThen
fn=ThisWorkbook.Path&"\"&filename
Workbooks.Open(fn)
ActiveWorkbook.Worksheets
(1).Select
ActiveSheet.Range("g2").Value="长期收益率"
ActiveSheet.Range("h2").Value="长期峰度"
ActiveSheet.Range("i2").Value="长期偏度"
ActiveSheet.Range("l2").Value="每年收益率"
ActiveSheet.Range("m2").Value="每年峰度"
ActiveSheet.Range("n2").Value="每年偏度"
ActiveSheet.Range("e3").Select
ActiveCell.FormulaR1C1="=LN(RC[-1]/R[-1]C[-1])"
k=ActiveSheet.Range("A1").CurrentRegion.Rows.Count
ActiveSheet.Range("e3").Select
Selection.AutoFillDestination:
=Range("e3:
e"&k)
ActiveSheet.Cells(3,8).Formula="=KURT(e3:
e"&k&")"'算十年
ActiveSheet.Cells(3,9).Formula="=skew(e3:
e"&k&")"
ActiveSheet.Cells(3,7).Formula="=d"&k&"/d2-1"
'选中活动工作表
'非空单元格的行号
ActiveSheet.Range("j3").Select
ActiveCell.FormulaR1C1="=TEXT(RC[-7],""yyyy"")"'j1输入文本
Range("J3").Select
Selection.AutoFillDestination:
=Range("J3:
J"&k)'自动填充所有行
Setrng1=ActiveSheet.Range("j3")
i=3
DoWhilerng1<>""
c=rng1.Row
b=0
ForEachrng2InRange("j:
j")
Ifrng2.Value=rng1.ValueThen
b=b+1
EndIf
Next'获得每一年的个数
d=rng1.Offset(b-1,0).Row
e=rng1.Value
ActiveSheet.Cells(i,11).Value=e
ActiveSheet.Cells(i,13).Formula="=KURT(e"&c&":
e"&d&")"
ActiveSheet.Cells(i,14).Formula="=skew(e"&c&":
e"&d&")"
ActiveSheet.Cells(i,12).Formula="=d"&d&"/d"&c&"-1"
i=i+1
Setrng1=rng1.Offset(b,0)
Loop
ActiveWorkbook.Closesavechanges:
=True
EndIf
filename=Dir
Loop
Application.ScreenUpdating=True
EndSub
------------批量总表
Dima,c,e,dAsString
DimsheetAsWorksheet
Dimb,i,f,kAsLong
Dimfilename,fnAsString
filename=Dir(ThisWorkbook.Path&"\*.xls")
Application.ScreenUpdating=False
Setrng1=ThisWorkbook.Sheets
(1).Range("a1048576").End(xlUp).Offset(1,0)
i=1
DoWhilefilename<>""
Iffilename<>ThisWorkbook.NameThen
fn=ThisWorkbook.Path&"\"&filename
Workbooks.Open(fn)
ActiveWorkbook.Worksheets
(1).Select
WithActiveWorkbook.Worksheets
(1)
.Range("b2").Copy
ThisWorkbook.Sheets
(1).Cells(i,1).PasteSpecialxlPasteValues
.Range("g3:
i3").Copy
ThisWorkbook.Sheets
(1).Cells(i,2).PasteSpecialxlPasteValues
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VBA 代码 汇总