VBA代码汇总

' 宏1 宏

' 超链接

 Dim p$, f$, i As Integer

 i = 1

 国创撰写\\" & ""

 取得第一个pdf文件名

 循环语句

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

 显示路径加文件名

      f = Dir   '第二个文件名

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

 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

 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)

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

 取得第一个excel文件名

 循环语句

        Set rng = wb.Range("A1048576").End(xlUp).Offset(1, 0)                          ' ‘Set wb1 = "D:\学习\大二下\\srp创新网络与创新绩效\新建文件夹\第五阶段数据编码47—80\第四阶段数据编码47—80\\" & f

    Selection.AutoFilter    '筛选 已验证过没问题

 发明申请"

 显示路径加文件名

      f = Dir   '第二个文件名

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

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

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

  Set abc = abc.Offset(b + 1, 0)

Loop

End Sub

Sub 遍历工作表求偏度峰度

 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

 选中活动工作表

   ‘k = ActiveSheet.Range("A1").CurrentRegion.Rows.Count  ‘ 取得最后一行的行号 k 为long

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

 非空单元格的行号

 输入文本

 自动填充所有行

Do While rng1 <> ""

 获得每一年的个数

 计算

next

-探戈写的代码：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 <> ThisWorkbook.Name 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 <> ""

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

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

 长期偏度"

 每年收益率"

 每年峰度"

 每年偏度"

 （e3:e" & k & ") " '算十年

 ：e" & k & ") "

 选中活动工作表

 非空单元格的行号

 输入文本

 自动填充所有行

Do While rng1 <> ""

 获得每一年的个数

 （e" & c & ":e" & d & ") "

 （e" & c & ":e" & d & ") "

 ActiveWorkbook.Close savechanges:=True

End If

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)

 i = 1

Do While filename <> ""

If filename <> ThisWorkbook.Name Then

 ActiveWorkbook.Close savechanges:=True

End If

  i= i+1

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)  '定义代码所在工作簿的变量

 取得所在文件夹的第一个excel文件名

 循环语句

 ’判断该文件是否是代码所在工作簿

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

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

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

    wb1.Close False   ’关闭其它工作簿

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

      Loop   '执行循环

Application.ScreenUpdating = True ’打开屏幕更新

End Sub