VBA代码汇总

Sub 批量超链接word文档()

' 宏1 宏

' 超链接

Dim p$, f$, i As Integer

i = 1

p = "C:UsersAdministratorDesktop国创撰写" & ""

f = Dir(p & "*.docx") '取得第一个pdf文件名

Do While f <> "" ' 循环语句

te

Sheets(1).Cells(i, 1).Value = f 'Range("a1").Value = p & f

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) =

arr(2) =

arr(3) =

随机

arr(4) =

MsgBox "excel推荐你今天应该吃" & arr(shu)

End Sub

Private Sub CommandButton2_Click()

Unload Me

End Sub

Sub 批量新建指定名称工作簿()

yAlerts = 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 = Rng Then

b = b + 1

End If

Next

(b, 0).

Shift:=xlDown

Shift:=xlDown

Range("A1"). (b, -4)

Set wb =

'Filename:= & parator & Rng & ".xls"

(1).Activate

(1).Activate

(1).Paste

"C:UsersAdministratorDesktop团队人员统计" & Rng & ".xlsx" '之前忘了保存了

(1).Activate

(b + 1, 0).Select

Next

yAlerts = True

End Sub

Sub 输入输出()

Dim abc As String

abc = InputBox("你想问什么", "这是一个标题")

Call MsgBox("房主你最帅 ^ ^", 0, "这是标题")

'加了括号一定要返回值，或者加call

'Dim wb As Workbook

' Set wb =

' Filename:= & parator & "" '搞定名称啦！

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 = Rng Then

b = b + 1

End If

Next

' MsgBox b

(b, 0).

Shift:=xlDown

Shift:=xlDown

Worksheets("团队出勤").rea = s

Worksheets("团队出勤").PrintOut

Range("a1"). (b, 0)

(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

Updating = False

Set wb = eets(1)

' p = "D:学习大二下srp创新网络与创新绩效新建文件夹第五阶段数据编码47—80第四阶段数据编码47—80" & ""

f = Dir( & "*.xls") '取得第一个excel文件名

Do While f <> "" ' 循环语句

Set rng = ("A1048576").End(xlUp).Offset(1, 0)

' ‘Set wb1 = "D:学习大二下srp创新网络与创新绩效新建文件夹第五阶段数据编码47—80第四阶段数据编码47—80" & f

z = & "" & f

Set wb1 = GetObject(z)

(2).Activate

Columns("Q:Q").Select

lter '筛选 已验证过没问题

("Q:Q").AutoFilter Field:=1, Criteria1:="发明申请"

Rows("2:2").Select

Shift:=xlDown

Range("a3"). rng

False

'te

' Set rng = eets(1).Range("A1048576").End(xlUp).Offset(1, 0)

' pecial Paste:=xlPasteValues

'Range("a1").Value = p & f

'MsgBox p & f 显示路径加文件名

f = Dir '第二个文件名

Loop

Updating = True

End Sub

Sub 股票分类建立工作表()

yAlerts = 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 = Rng Then

b = b + 1

End If

Next

Worksheets("沪深300成分股10年").Activate

(b, 0).

Shift:=xlDown

Set sht =

= Rng

Worksheets("沪深300成分股10年").Activate

("a1")

Set abc = (b + 1, 0)

Rng =

Loop

End Sub

Sub 遍历工作表求偏度峰度

For Each sheet In Sheets

("F1").Select

aR1C1 = "=LN(RC[-2]/RC[-1])"

Set rng = ("A1048576").End(xlUp)

a =

("F2").Select

aR1C1 = "=LN(RC[-2]/R[-1]C[-2])"

("F2").Select

ll Destination:=Range("F2:F" & a)

("F2:F" & a).Select

("G1").Select

aR1C1 = "=KURT(C[-1])"

("H1").Select

aR1C1 = "=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

Updating = false

For Each sheet In Sheets

'选中活动工作表

‘k = ("A1"). ‘ 取得最后一行的行号 k 为long

Set rng = ("A1048576").End(xlUp) '获得最后一个非空单元格

a = '非空单元格的行号

("j1").Select

aR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本

Range("J1").Select

ll Destination:=Range("J1:J" & a) '自动填充所有行

Set rng1 = ("j1")

i = 1

Do While rng1 <> ""

c =

b = 0

For Each rng2 In Range("j:j")

If = Then

b = b + 1

End If

Next '获得每一年的个数

d = (b - 1, 0).Row

e =

(i, 11).Value = e

(i, 12).Value = (("F" &

c & ":F" & d))

(i, 13).Value = (("F" &

c & ":F" & d)) '计算

i = i + 1

Set rng1 = (b, 0)

Loop

next

Updating = 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( & "*.xls")

Do While Filename <> ""

If Filename <> Then

fn = & "" & Filename

(fn)

With eets(1)

Cells(65536, "A").End(xlUp).

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

savechanges:=True

End If

Filename = Dir

Loop

End Sub

使用a 调用工作表函数

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( & "*.xls")

Updating = False

Do While filename <> ""

If filename <> Then

fn = & "" & filename

(fn)

eets(1).Select

("g2").Value = "长期收益率"

("h2").Value = "长期峰度"

("i2").Value = "长期偏度"

("l2").Value = "每年收益率"

("m2").Value = "每年峰度"

("n2").Value = "每年偏度"

("e3").Select

aR1C1 = "=LN(RC[-1]/R[-1]C[-1])"

k = ("A1").

("e3").Select

ll Destination:=Range("e3:e" & k)

(3, 8).Formula = "=KURT（e3:e" & k & ") " '算十年

(3, 9).Formula = "=skew(e3：e" & k & ") "

(3, 7).Formula = "=d" & k & "/d2 -1 "

'选中活动工作表

'非空单元格的行号

("j3").Select

aR1C1 = "=TEXT(RC[-7],""yyyy"")" 'j1输入文本

Range("J3").Select

ll Destination:=Range("J3:J" & k) '自动填充所有行

Set rng1 = ("j3")

i = 3

Do While rng1 <> ""

c =

b = 0

For Each rng2 In Range("j:j")

If = Then

b = b + 1

End If

Next '获得每一年的个数

d = (b - 1, 0).Row

e =

(i, 11).Value = e

(i, 13).Formula = "=KURT（e" & c & ":e" & d & ") "

(i, 14).Formula = "=skew（e" & c & ":e" & d & ") "

(i, 12).Formula = "=d" & d & "/d" & c & "-1 "

i = i + 1

Set rng1 = (b, 0)

Loop

savechanges:=True

End If

filename = Dir

Loop

Updating = 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( & "*.xls")

Updating = False

Set rng1 = (1).Range("a1048576").End(xlUp).Offset(1, 0)

i = 1

Do While filename <> ""

If filename <> Then

fn = & "" & filename

(fn)

eets(1).Select

With eets(1)

.Range("b2").Copy

(1).Cells(i, 1).PasteSpecial xlPasteValues

.Range("g3:i3").Copy

(1).Cells(i, 2).PasteSpecial xlPasteValues

End With

savechanges:=True

End If

i= i+1

filename = Dir

Loop

Updating = True

End Sub

Public Sub 汇总工作簿的不同工作表()

Dim f$, z$, i As Long '定义变量

Dim wb As Worksheet

Dim wb1 As Workbook

Dim rng As Range

Updating = False ’关闭屏幕更新，加快运行速度

Set wb = eets(1) '定义代码所在工作簿的变量

f = Dir( & "*.xls") '取得所在文件夹的第一个excel文件名

Do While f <> "" ' 循环语句

If f <> Then ’判断该文件是否是代码所在工作簿

Set rng = ("A1048576").End(xlUp).Offset(1, 0) '取得所要汇总的工作簿的A列第一个非空单元格

z = & "" & f

Set wb1 = (z) ’打开其他的工作簿

(1).Range("B6"). rng '开始复制其他工作簿的内容到指定位置。此处的单元格B6可以替换成自己想要的位置。

False ’关闭其它工作簿

End If

f = Dir '取得下一个文件名

Loop '执行循环

Updating = True ’打开屏幕更新

End Sub