VBA代码汇总

VBA代码汇总
Sub 批量超链接word文档()
' 宏1 宏
' 超链接
Dim p$, f$, i As Integer
i = 1
p = "C:\Users\Administrator\Desktop\国创撰写\" & ""
f = Dir(p & "*.docx") '取得第一个pdf文件名
Do While f <> "" ' 循环语句
ThisWorkbook.Activate
Sheets(1).Cells(i, 1).Value = f 'Range("a1").Value = p & f
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=p & f, _
TextToDisplay:=f
'MsgBox p & f 显示路径加文件名
f = Dir '第二个文件名
i = i + 1
Loop
End Sub
Private Sub CommandButton1_Click() 随机选择器
Dim a, b, c, d As String
Dim shu As Integer
Dim arr(1 To 4)
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)
End Sub
Private Sub CommandButton2_Click() Unload Me
End Sub
Sub 批量新建指定名称工作簿() Application.DisplayAlerts = False
For i = 1 To 54 ' 个数减一
Dim Rng As String
Dim abc As Range
Dim wb As Workbook
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
With ActiveCell
Rng = .Value
Set abc = .Offset(1, 0)
End With
Dim a As Range
Dim b As Long
b = 0
For Each a In Range("E:E")
If a.Value = Rng Then
b = b + 1
End If
Next
ActiveCell.Offset(b, 0).EntireRow.Select Selection.Insert Shift:=xlDown Selection.Insert Shift:=xlDown
abc.Select
Range("A1").EntireRow.Copy abc.Offset(b, -4) Set wb = 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
End Sub
Sub 输入输出()
Dim abc As String
abc = InputBox("你想问什么", "这是一个标题")
Call MsgBox("房主你最帅^ ^", 0, "这是标题")
'加了括号一定要返回值，或者加call
'Dim wb As Workbook
' Set wb = Workbooks.Add
' wb.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "woshi.xls" '搞定名称啦！
Sub 自动分组打印6_Click()
For i = 1 To 35
Dim Rng As String
Dim abc As Range
With ActiveCell
Rng = .Value
Set abc = .Offset(1, 0)
End With
Dim a As Range
Dim b As Integer
b = 0
For Each a In Range("A:A")
If a.Value = Rng Then
b = b + 1
End If
Next
' MsgBox b
ActiveCell.Offset(b, 0).EntireRow.Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
abc.Select
Worksheets("团队出勤").PageSetup.PrintArea = abc.CurrentRegion.Address
Worksheets("团队出勤").PrintOut
Range("a1").EntireRow.Copy abc.Offset(b, 0)
abc.Offset(b + 1, 0).Select
Next
End Sub
Public Sub多个工作表复制汇总()
Dim p$, f$, z$, i As Integer
Dim wb As Worksheet
Dim wb1 As Workbook
Dim rng As Range
Application.ScreenUpdating = False
Set wb = ThisWorkbook.Worksheets(1)
' p = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & ""
f = Dir(ThisWorkbook.Path & "\*.xls") '取得第一个excel文件
名
Do While f <> "" ' 循环语句
Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) ' ‘Set wb1 = "D:\学习\大二下\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\" & f z = ThisWorkbook.Path & "\" & f
Set wb1 = GetObject(z)
wb1.Sheets(2).Activate
Columns("Q:Q").Select
Selection.AutoFilter '筛选已验证过没问题
ActiveSheet.Range("Q:Q").AutoFilter Field:=1, Criteria1:="发明申请"
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Range("a3").CurrentRegion.Copy rng
wb1.Close False
'wb.Activate
' Set rng = wb.Worksheets(1).Range("A1048576").End(xlUp).Offset(1, 0) ' rng.PasteSpecial Paste:=xlPasteValues
'Range("a1").Value = p & f
'MsgBox p & f 显示路径加文件名
f = Dir '第二个文件名
Loop
Application.ScreenUpdating = True
End Sub
Sub 股票分类建立工作表()
Application.DisplayAlerts = False
Dim Rng As String
Dim abc As Range
Dim b As Integer
Dim a As Range
Dim sht As Worksheet
Rng = Worksheets("沪深300成分股10年").Range("b2").Value Set abc = Worksheets("沪深300成分股10年").Range("b2") Do While Rng <> ""
b = 0
For Each a In Range("b:b")
If a.Value = Rng Then
b = b + 1
End If
Next
Worksheets("沪深300成分股10年").Activate
abc.Offset(b, 0).EntireRow.Select
Selection.Insert Shift:=xlDown
Set sht = Worksheets.Add
/doc/a711863622.html, = Rng Worksheets("沪深300成分股10年").Activate
abc.CurrentRegion.Copy sht.Range("a1")
Set abc = abc.Offset(b + 1, 0)
Rng = abc.Value
Loop
End Sub
Sub 遍历工作表求偏度峰度
For Each sheet In Sheets
sheet.Select
ActiveSheet.Range("F1").Select
ActiveCell.FormulaR1C1 = "=LN(RC[-2]/RC[-1])"
Set rng = 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.AutoFill Destination:=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
End Sub
Sub 求单只股票每一年风度偏度()
'
Sub 每年()
'
' 每年宏
Dim rng, rng1, rng2 As Range
Dim a, c, e, d As String
Dim sheet As Worksheet
Dim b, i, f As Long
Application.ScreenUpdating = false
For Each sheet In Sheets
sheet.Select
'选中活动工作表
‘k= ActiveSheet.Range("A1").CurrentRegion.Rows.Count ‘ 取得最后一行的行号k 为long
Set rng = ActiveSheet.Range("A1048576").End(xlUp) '获得最后一个非空单元格
a = rng.Row '非空单元格的行号
ActiveSheet.Range("j1").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本
Range("J1").Select
Selection.AutoFill Destination:=Range("J1:J" & a) '自动填充所有行
Set rng1 = ActiveSheet.Range("j1")
i = 1
Do While rng1 <> ""
c = rng1.Row
b = 0
For Each rng2 In Range("j:j")
If rng2.Value = rng1.value Then
b = b + 1
End If
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
Set rng1 = rng1.Offset(b, 0)
Loop
next
Application.ScreenUpdating = True
-探戈写的代码：Sub test2()
Dim Filename As String, wb As Workbook, Erow As Long, fn As String, bj As Variant, i As Long, k As Long, j As Long, l As Long Filename = Dir(ThisWorkbook.Path & "\*.xls")
Do While Filename <> ""
If Filename <> /doc/a711863622.html, Then
fn = ThisWorkbook.Path & "\" & Filename
Workbooks.Open (fn)
With ActiveWorkbook.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").AutoFill Destination:=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
Do While k <> 2018
Do While bj = 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
End With
ActiveWorkbook.Close savechanges:=True
End If
Filename = Dir
Loop
End Sub
使用cells.formula 调用工作表函数
Cells(1, 1).Formula = "=sum（d" & l & ":d3) "
Sub 计算个股（单个工作簿工作表）的收益率和偏度峰度a()
'
Sub 计算偏度峰度a()
'
' 每年宏
Dim rng, rng1, rng2, rng3 As Range
Dim a, c, e, d As String
Dim sheet As Worksheet
Dim b, i, f, k As Long
Dim filename, fn As String
filename = Dir(ThisWorkbook.Path & "\*.xls")
Application.ScreenUpdating = False
Do While filename <> ""
If filename <> /doc/a711863622.html, Then
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.AutoFill Destination:=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.AutoFill Destination:=Range("J3:J" & k) '自动填充所有行Set rng1 = ActiveSheet.Range("j3")
i = 3
Do While rng1 <> ""
c = rng1.Row
b = 0
For Each rng2 In Range("j:j")
If rng2.Value = rng1.Value Then
b = b + 1
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
Set rng1 = rng1.Offset(b, 0)
Loop
ActiveWorkbook.Close savechanges:=True
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
------------批量总表
Dim a, c, e, d As String
Dim sheet As Worksheet
Dim b, i, f, k As Long
Dim filename, fn As String
filename = Dir(ThisWorkbook.Path & "\*.xls")
Application.ScreenUpdating = False
Set rng1 = ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)
Do While filename <> ""
If filename <> /doc/a711863622.html, Then
fn = ThisWorkbook.Path & "\" & filename
Workbooks.Open (fn)
ActiveWorkbook.Worksheets(1).Select
With ActiveWorkbook.Worksheets(1)
.Range("b2").Copy
ThisWorkbook.Sheets(1).Cells(i, 1).PasteSpecial xlPasteValues
.Range("g3:i3").Copy
ThisWorkbook.Sheets(1).Cells(i, 2).PasteSpecial xlPasteValues
End With
ActiveWorkbook.Close savechanges:=True
End If
i= i+1
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Public Sub 汇总工作簿的不同工作表()
Dim f$, z$, i As Long '定义变量
Dim wb As Worksheet
Dim wb1 As Workbook
Dim rng As Range
Application.ScreenUpdating = False ’关闭屏幕更新，加快运行速度
Set wb = ThisWorkbook.Worksheets(1) '定义代码所在工作簿
的变量
f = Dir(ThisWorkbook.Path & "\*.xls") '取得所在文件夹的第一个excel 文件名
Do While f <> "" ' 循环语句
If f <> /doc/a711863622.html, Then ’判断该文件是否是代码所在工作簿
Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0) '取得所要汇总的工作簿的A列第一个非空单元格
z = ThisWorkbook.Path & "\" & f
Set wb1 = Workbooks.Open(z) ’打开其他的工作簿
wb1.Sheets(1).Range("B6").CurrentRegion.Copy rng '开始复制其他工作簿的内容到指定位置。

此处的单元格B6可以替换成自己想要的位置。

wb1.Close False ’关闭其它工作簿
End If
f = Dir '取得下一个文件名
Loop '执行循环
Application.ScreenUpdating = True ’打开屏幕更新End Sub。