【转载】EXCEL VBA Workbook、Worksheet、Range的选择和操作

Workbooks对象是Microsoft Excel 应用程序中当前打开的所有 Workbook 对象的集合。有close、add、open等方法。

 

Workbooks.close              '  关闭所有打开的工作簿。

Workbooks.Add               '  创建一个新工作簿。

ActiveWorkbook            '返回当前处于活动状态的工作簿。

Workbooks.open Filename:="TEST.XLSX", ReadOnly:=True     '  将文件TEST.XLSX打开为只读工作簿

 

Workbook对象是一个Microsoft Excel 工作簿。有Name、Path等属性。有SaveAs等方法。有Open、Activate等事件。

     ThisWorkbook属性返回运行Visual Basic代码的工作簿。当Visual Basic代码是加载宏的组成部分时，返回加载宏的工作簿，而非调用该加载宏的工作簿。

使用 Workbooks(index)（其中 index 是工作簿名称或索引号）可返回一个 Workbook 对象。index指创建或打开工作簿的顺序。Workbooks(1) 是创建的第一个工作簿，而 Workbooks(Workbooks.Count)Workbooks返回最后一个打开的工作簿。激活某工作簿并不更改其索引号。所有工作簿均包括在索引计数中，即便是隐藏工作簿也是。

 

Workbooks(1).Activate           ' 激活工作簿一（创建或打开的第一个工作簿）。

Workbooks("TEST.xlsx").Worksheets("Sheet1").Activate    ' 激活名为“TEST.xlsx”的工作簿（该工作簿必须已经在 Microsoft Excel 中打开）中的 Sheet1。

ActiveWorkbook.Author = "Jean Selva"            '  设置活动工作簿作者的名称。

 

Sheets集合是指定的或者活动工作簿中所有的工作表（图表工作表Chart和工作表Worksheet）的集合。有Add等方法。

使用 Sheets(index)（其中 index 是工作表名称或索引号）可返回一个 Chart 或 Worksheet 对象。工作表索引号指示该工作表在工作簿的标签栏上的位置。所有工作表均包括在索引计数中，即便是隐藏工作表也是。

 

 Sheets(array)                    ‘可指定多个工作表。

Worksheets(1)                     '工作簿中第一个（最左边的）工作表

Worksheets(Worksheets.Count)            '最后一个打开的工作表。

Sheets(1).Activate                               ' 激活活动工作簿中的工作表二。

Sheets("sheet1").Activate                     ' 激活活动工作簿中名为“Sheet1”的工作表。

Sheets(Array("Sheets4", "Sheet5")).Move before:=Sheets(1)        '  将名为"Sheet4"和"Sheet5"的工作表移到活动工作簿的开头。

 

Worksheets对象是指定的或者活动工作簿中所有WorkSheet对象的集合。有Add等方法。

 

使用 Worksheets(index)（其中 index 是工作表索引号或名称）可返回一个 Worksheet 对象。工作表索引号指示该工作表在工作簿的标签栏上的位置。所有工作表均包括在索引计数中，即便是隐藏工作表也是。

Worksheets(1)                                 '工作簿中第一个（最左边的）工作表

Worksheets(Worksheets.Count)          '最后一个工作表。

Worksheets.move After:=Sheets(SHeets.Count)          ' 将所有工作表都移到工作簿的尾部，即将图表工作表都放在工作表之前。

Worksheets.Add count:=2, Before:=Sheets(1)            '  在活动工作簿的工作表一之前创建两个新工作表。

Worksheets(1).Visible = False                                 '  隐藏活动工作簿中的工作表一。

 

Worksheet对象代表一个工作表。有Name等属性。有Activate、Delete等方法。有Name、Cells等属性。有Activate、Change等事件。

 

使用 Worksheets(index)（其中 index 是工作表索引号或名称）可返回一个 Worksheet 对象。工作表索引号指示该工作表在工作簿的标签栏上的位置。所有工作表均包括在索引计数中，即便是隐藏工作表也是。工作表名称是工作表的标签上显示的名称。

ActiveSheet                    '返回当前处于活动状态的工作表。如果没有活动的工作表，则返回Nothing。

Worksheets(1)                '是工作簿中第一个（最左边的）工作表

Worksheets(Worksheets.Count)        '最后一个工作表

 

Range对象代表某一单元格、某一行、某一列、某一选定区域（可包含一个或多个连续单元格区域）或某一三维区域。有Clear、Copy等方法。有Cells、Value、Font等属性。

 

Range("A1).Value = "test"        

             ' 将活动表上的A1单元格赋值为“test”。如果活动表不是工作表，则失败。

Worksheets("sheet1").Range("A5").Value = "test"           

             ' 将活动工作簿中名为“Sheet1”的工作表上的A1单元格赋值为“test”。字母大写或小写都可以。

Worksheets("Sheet1").Range("A1:H8").Formula = "=Rand()"          

            ' 为活动工作簿中名为“Sheet1”的工作表上的区域A1:H8中的每个单元格设置公式。

Worksheets(1).Range("Criteria").ClearContents

           ' 清除区域名为“Critiria”的区域中的内容。

Range("1:4").Select                       '  选择第1到4行

Range("A:C").Select                      '  选择A到C列

Range("A:C").EntireColumn.Insert    ' 在第1列左边插入三列空白列

 

使用 Cells(row, column)（其中 row 是行号，column 是列标）可返回一个单元格。当工作表激活以后，使用 Cells 属性时不必明确声明工作表（它将返回活动工作表上的单元格）。column列标可以是字母格式的，例如Cells(1,"A")；也可以是数字格式的。row行号和column列标可以为变量。

Worksheets("sheet1").Cells(1,1).Value = "test"

              ' 将活动工作簿中名为“Sheet1”的工作表上的A1单元格赋值为“test”。

使用 Range(cell1, cell2)（其中 cell1 和 cell2 是指定起始和终止单元格的 Range 对象）可返回一个 Range 对象。

Worksheets(1).Range(Worksheets(1).Cells(1,1), Worksheets(1).Cells(10,10)).Borders.LineStyle = xlThick

             '设置单元格区域A1:J10的边框线条的样式。如果Cells之前没有句点及其左边的对象（对象识别符），Cells 属性将返回活动工作表上的单元格。

Worksheets("Sheets1").Range("A5:H8").Cells(1,1).Formula = "=Rand()"             '为A5单元格设置公式。

使用Union可返回多块区域，即该区域由多个连续的单元格区域所组成。

Union(Range("A1:B2", Range(C3:D4")).Select               ' 选定多块区域。

Range.Areas属性将多区域选定内容拆分为单个的Range对象，并将对象返回为一个集合。

x = Selection.Areas.Count

                     ' 返回多区域选定内容中的连续区域单元格的数量。

 

Range.CurrentRegion属性返回一个Range对象，该对象表示当前区域（当前区域是以空行与空列的组合为边界的区域）。

ActiveCell.CurrenRegion.Select      '  选定活动单元格所在的当前区域。

 

ListObject对象代表工作表中的表格/列表对象（即在工作表中插入表格后形成的列表）。

ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$B$2"), , xlYes).Name = "表1"

             ' 将活动工作表中的”A1:B2“区域转化为表格，命名为”表1“

ActiveSheet.ListObjects("表1").Name = "表ABC"

            '  将表格名称改为”表ABC”

ActiveSheet.ListObjects("表ABC").Resize Range("$A$1:$B$10")

            '  将表格区域改为”A1:B10“

 

Range.Row属性返回区域中第一个子区域的第一行的行号。

x = Selection.Row

                  ' 返回选定区域的行号。

Range.Rows属性返回一个Range对象

Worksheets("Sheet1").Rows(3).Delete

x = Selection.Rows.Count

               ' 返回选定区域的行数。

可以直接使用单元格地址进行选择和操作，但地址中不可包含变量。

[b7].Select            ' 选定B7单元格。单元格地址用字符串表达，如A1、B3等，字母可小写。注意用中括号括起单元格地址。

[a1:B5].Select              ' 选择单元格区域

Range("A1", "E10").Select

Range(Range("A1"), Range("E10")).Select   '与上一语句等价

[a1:a3,c1:c5].Select                   ' 选择多个单元格区域

ActiveSheet.Cells.Select            '选中活动工作表的所有单元格

Range("B3:E9").Select              '选中活动工作表中B3:E9单元格区域

 

多区域选择

1、引用多个不连续的区域，用逗号隔开

    Range("A1:A10,A4:E6,C3:D9")

    [A1:A10,C1:C10,E1:E10]

2、用空格而不是逗号，则表示选中区域交集部分

    Range("A1:B10 A4:D9")

    [B3:D10 A4:G8]

 

其他获取单元格的方式（除了Range、Cells外）—Rows 

ActiveSheet.Rows                                   '选中活动工作表的所有行

ActiveSheet.Rows(3).Select                       '选中活动工作表的第3行

ActiveSheet.Rows(3).EntireRow.Select         '选中活动工作表的第3行整行

ActiveSheet.Rows("3:3").Select                  '选中活动工作表的第3行

ActiveSheet.Rows("3:5").Select                   '选中活动工作表的第3行到第5行

Rows("3:10").Rows("1:1").Select                 '选中第3行到第10行区域内的第一行

ActiveCell.EntireRow.Select                '选择这个单元格所在的整行

ActiveCell.EntireRow.Offset(1, 0).Cells(1).Value = 2  

         ’选择任意一个单元格，然后将值2输入到包含活动单元格的行下面的第一个单元格中。

ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate

           ‘激活 Sheet1 上活动单元格右移三列且下移三行的单元格

ActiveCell.CurrentRegion               '激活单元格的当前区域

 

其他获取单元格的方式（除了Range、Cells外）—Columns 

ActiveSheet.Columns                                       '选中活动工作表的所有列

ActiveSheet.Columns (6)                                  '选中活动工作表中的第6列

ActiveSheet.Columns (6).EntireColumn           '选中活动工作表中的第6列整列

ActiveSheet.Columns ("F:G")                            '选中活动工作表中的F至G列

Columns("B:G").Columns("B:B").Select               '选中B:G区域中的第2列

ActiveCell.EntireColumn.Select                         '选中单元格的整列

ActiveCell.EntireColumn.Cells(1).Value = 2  ‘选择任意一个单元格，然后将值2输入到包含这个活动单元格的列的第一个单元格中。

 

Application的Union方法

Union方法像一支强烈的粘合剂，将不连续的多个单元格区域粘在一起，可以同时对其进行操作。

Sub rngUnion()

   Application.Union(Range("A1:A10"), Range("D1:D5")).Select 

          '入参至少为2个区域，至多30个区域，区域之间用逗号分隔

    Union(Range("A1:A10"), Range("D1:D5")).Select  

          'application可以省略不写

End Sub

 

Range对象的Offset属性

 Offset属性用来基于基于单元格的位置移动

Offset(x,y)两个参数，x表示行移动，即x>0表示向下移动，x<0表示向上移动；y表示列移动，即y>0表示向右移动，y<0表示向左移动。

Sub rngOffset()

    Range("A1").Offset(2, 3).Value = 500

             '基于“A1”单元格，向下移动2行，向右移动3列

   Range("C5:D6").Offset(-3, 0).Select 

            '在“C5：D6”区域的基础上，向上移动3行，列方向参数为0，不移动。

End Sub

 

Range对象的Resize属性

 使用Range对象的Resize属性扩大或缩小指定的单元格区域，得到一个新的单元格区域。

Resize共有两个参数，第一个参数确定新区域的行数，第二个参数确定新区域的列数，两个参数的值都是正整数，最小为1.

新区域把该对象最左上角的单元格当成自己左上角第一个单元格

Sub rngResize()

             '将B2单元格扩大为B2:E6

    Range("B2").Resize(5, 4).Select

            '将B2：E6单元格缩小为B2：B3，新区域以B2单元格为最左上角单元格

    Range("B2:E6").Resize(2, 1).Select

              '上句等同于

   Range("B2:E6").Cells(1).Resize(2, 1).Select

End Sub

 

Worksheet对象的UsedRange属性

 UsedRange属性返回工作表中已经使用的单元格围成的矩形区域（不管这些区域间是否有空行，空列或空单元格）。

Sub rngUsed()

     ActiveSheet.UsedRange.Select

End Sub

 

Range对象的CurrentRegion属性

CurrentRegion返回当前区域，即以空行和空行的组合为边界的区域

Sub rngUsed()

      Range("D3").CurrentRegion.Select

End Sub

 

Range对象的End属性

 End属性返回当前区域结尾处的单元格，等同于在源单元格按得到的单元格。

Sub rngEnd()

      Range("E5").End(xlUp).Select

End Sub

共有4个参数，说明如下：

xlUP        向上

xlDown    向下

xltoleft    向左

xltoright   向右

 

什么情况会用到End属性？工作表中记录的行数随时都在变化，应该把新记录写入工作表的第5行还是第10行？

可以用End属性解决这个问题

复制代码

Sub rngEnd()

              '取第一个单元格，如果非空则向下移动一个单元格，否则不移动。对新单元格进行赋值

    Dim c As Range

    Set c = ActiveSheet.Range("A65536").End(xlUp)

    If c.Value <> "" Then

       Set c = c.Offset(1, 0)

    End If

    c.Value = "张青"

End Sub

 

Sub rngUsed()

            '取使用区域内行数增加1，对该行的A列进行赋值

    Dim xrow As Long

    xrow = ActiveSheet.UsedRange.Rows.Count + 1

    Cells(xrow, "A").Value = "张青"

End Sub

 

Sub rngCurr()

            '取当前区域内行数增加1，对该行的A列进行赋值

    Dim xrow As Long

    xrow = Range("A1").CurrentRegion.Rows.Count + 1

    Cells(xrow, "A").Value = "张青"

End Sub

 

单元格内容-Value

 

Range("A1:B2").Value = "abc"

Range("A1:B2") = "abc" 'Value是Range的默认属性，在给区域赋值时可以省略。

单元格个数-Count

 

Range("B4:F10").Count  '统计单元格数量

ActiveSheet.UsedRange.Rows.Count '统计活动单元格的行数

ActiveSheet.UsedRange.Columns.Count '统计活动单元格的列数

单元格地址-Address

 MsgBox "当前选中的单元格地址为"&Selection.Address

 

选中单元格-Active与Select

以下两组代码是等效的。 

   ActiveSheet.Range("A1:B10").Select

   ActiveSheet.Range("A1:B10").Activate

 

选择性清除单元格-Clear 

Range("B2:B15").Clear '清除B2:B15单元格所有内容（包括批注、内容、注释、格式等）

Range("B2:B15").ClearComments '清除B2:B15单元格批注

Range("B2:B15").ClearContents '清除B2:B15单元格内容

Range("B2:B15").ClearFormats '清除B2:B15单元格格式

 

复制&粘贴单元格区域-Copy&Paste

录制复制和粘贴的宏内容如下：

Sub Macro1()

    Range("A1").Select

    Selection.Copy

    Range("C1").Select

    ActiveSheet.Paste

End Sub

但在执行复制或者粘贴操作之前并不需要选中单元格，所以代码可以简化为：

Sub Macro1()

    Range("A1").Copy Range("C1")               ' A1是源单元格，C1是目标单元格

End Sub

 

带参数的复制-Destination

Sub Macro1()

    Range("A1").Copy Destination:=Range("C1") 

              'A1是源单元格，C1是目标单元格,Destination是目标

End Sub

 

带参数的复制-CurrentRegion

 要复制的单元格区域不能确定大小，可以只指定一个单元格作为目标区域的最左上角单元格

Sub Macro1()

   Range("A1").CurrentRegion.Copy Range("C1") 

           'A1是源单元格，C1是目标单元格,Destination是目标

End Sub

 

想粘贴源区域的数值（以下两个式子等价）

Sub rngCopyValue_1()

   Range("A1:A10").Copy

   Range("F1:F10").PasteSpecial Paste:=xlPasteValues        '仅粘贴数值

End Sub

Sub rngCopyValue_2()

    Range("A1:A10").Value = Range("F1:F10").Value

End Sub

 

剪切单元格-Cut 

Sub rngCut()

    Range("A1:A5").Cut Destination:=Range("G1") 

                     '把A1:A5剪切到G1:G5，这里G1表示以G1为左上角第一个单元格的区域

    Range("F6:F10").Cut Range("G6") 

                    把F1:F10剪切到G6:K10，参数Destination可以省略

End Sub

 

删除单元格-Delete

 Delete有4个选项，分别对应如下参数：

Range("B5").Delete Shift:=xlToLeft '删除B5单元格，删除后右侧单元格左移

Range("B5").Delete Shift:=xlUp '删除B5单元格，删除后下方单元格上移

Range("B5").EntireRow.Delete '删除B5单元格所在的行

Range("B5").EntireColumn.Delete '删除B5单元格所在的列

 

单元格名称，Names集合

Excel中定义的名称就是给单元格区域（或数值、常量、公式）取的名字，一个自定义的名称及时一个Name对象，Names是工作簿中定义的所有名称的集合。

 

新建名称

录制的宏告诉我们，怎样新建一个名称

           'Add新建名称的方法，RefersToR1C1表示使用R1C1引用样式

ActiveWorkbook.Names.Add Name = "date", RefersToR1C1:="Sheet1!R5C[-2]"

R5C[-2]说明：R后面的数值表示行号，C后面的数值表示列号，[]中括号表示相对引用，默认是绝对引用，相对应用时R>0表示向下移动，C>0表示向右移动

R[2]C[3]：对活动单元格下方的第二行与右边的第3列相交的单元格的引用

R2C3：对工作表中第二行与第3列相交的单元格的引用

 

另一种单元格引用方式：A1样式引用

              'Add新建名称的方法，RefersToR1C1表示使用A1引用样式,$表示相对绝对引用，将把活动单元格当做A1单元格

ActiveWorkbook.Names.Add Name = "date", RefersTo:="Sheet1$B$4"

 

定义名称更简单的方式

Range("A1:C10") = "date"

 

怎样引用名称

ActiveWorkbook.Names("date").Name = "姓名"

ActiveWorkbook.Names("姓名").Name = "张三"

 

也可以使用名称索引引用名称

Sub UseName()

    Dim i, mx As Integer

    mx = ActiveWorkbook.Names.Count '统计一共有多少个单元格

    For i = 1 To mx

       activateworkbook.Names(i).Visible = False '隐藏名称

    Next

End Sub

 

单元格批注，Comment对象

一个批注就是一个Comment对象，Comments是工作簿中所有Comment对象的集合

 

给单元格增加批注

Range("B5").AddComment Text:="我用VBA新建的批注"

 

怎么知道单元格是否有批注

Sub wbComment()

    Range("B5").AddComment Text:="我用VBA新建的批注"

    If Range("B5").Comment Is Nothing Then '判断是否存在Comment对象

       MsgBox "B5单元格中没有批注"

    Else

       MsgBox "B5单元格中已有批注"

    End If

End Sub

 

操作批注

Sub operComment()

    Range("B5").AddComment Text:="我用VBA新建的批注" '新建批注

   Range("B5").Comment.Visible = False '隐藏B5单元格批注

   Range("B5").Comment.Delete '删除B5单元格批注

End Sub

 

给单元格化妆

 设置字体-Font

Sub FontSet()

    With Range("A1:L1").Font

       .Name = "宋体" '设置字体为宋体

       .Size = 12 '设置字号为12号

       .Color = RGB(255, 0, 0) '设置字体颜色为红色

       .Bold = True '设置字体加粗

       .Italic = True '设置字体倾斜显示

       .Underline = xlUnderlineStyleDouble 'feud文字添加双下划线

    End With

End Sub

 

给单元格增加底纹-Interior

Sub InteriorSet()

   Range("A1:L1").Interior.Color = RGB(255, 255, 0) '增加黄色底纹

End Sub

 

给表格设置表框

Sub InteriorSet()

    With Range("A1").CurrentRegion.Borders

       .LineStyle = xlContinuous '设置单线边框

       .Color = RGB(0, 0, 255) '设置边框颜色

       .Weight = xlHairline '设置边框线条样式

    End With

End Sub

 

编写一个程序，按要求创求的一个新的工作簿，并把它保存到指定的文件夹。 

Sub wbAdd()

   '程序创建“员工花名册”工作簿，保存在本工作簿所在的文件夹中

    Dim wb As Workbook, sht As Worksheet '定义一个Workbook对象和一个Worksheet对象

    Set wb = Workbooks.Add '新建一个工作簿

    Set sht = wb.Worksheets(1)

    With sht

       .Name = "花名册" '修改第一张工作表的标签名称

       .Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "参加工作时间", "备注") '设置表头

    End With

    wb.SaveAs ThisWorkbook.Path & "\员工花名册.xls" '保存新建的工作表到本工作簿所在的文件夹中

    ActiveWorkbook.Close '关闭新建的工作簿

End Sub

 

判断工作簿是否打开

'判断"成绩表.xls"工作簿是否打开

Sub isWbOpen()

    Dim i As Integer

    For i = 1 To Workbooks.Count

       If Workbooks(i).Name = "成绩表.xls" Then

           MsgBox "文件已打开"

           Exit Sub '如果找到该文件，退出过程

       End If

    Next

    MsgBox "文件没有打开"

End Sub

 

 工作表是否打开判断

         '判断打开的工作表中是否含“一年级”，有则移动到第一个位置，否则在第一个位置创建

Sub isShtOpen()

    Dim sht As Worksheet

    For Each sht In Worksheets

       If sht.Name = "一年级" Then

           sht.Move before:=Worksheets(1)

           'MsgBox "已经打开"

           Exit Sub

       End If

    Next

   Worksheets.Add(before:=Worksheets(1)).Name = "一年级"

End Sub

 

 另一种写法：

         '判断打开的工作表中是否含“一年级”，有则移动到第一个位置，否则在第一个位置创建

Sub isShtOpen()

    On Error Resume Next

    If Worksheets("一年级") Is Nothing Then

       Worksheets.Add(before:=Worksheets(1)).Name = "一年级"

    Else

       Worksheet("一年级").Move before:=Worksheets(1)

       'MsgBox "已经打开"

    End If

End Sub

 

判断工作簿是否存在 

Sub isExistWb()

   '判断本工作簿所在的文件夹中是否存在“员工花名册.xls”

    Dim fil As String

    fil = ThisWorkbook.Path & "\员工花名册.xls"

    If Len(Dir(fil)) > 0 Then

       MsgBox "工作簿已经存在"

    Else

       MsgBox "工作簿不存在"

    End If

End Sub

 

向未打开的工作簿中录入数据 

Sub WbInput()

   '在本工作簿所在的文件夹下“员工花名册”里添加一条记录

    Dim wb As String, xrow As Integer, arr

    wb = ThisWorkbook.Path & "\员工花名册.xls"

    Workbooks.Open (wb)

    With ActiveWorkbook.Worksheets(1)

       xrow = .Range("A1").CurrentRegion.Rows.Count + 1

       arr = Array(xrow - 1, "张娇", "女", "#7/8/1987#", "#9/1/2010#", "10年新招")

       .Cells(xrow, 1).Resize(1, 6) = arr

    End With

    ActiveWorkbook.Close savechanges:=True

End Sub

 

隐藏活动工作表外的所有工作表 

Sub ShtVisible()

    '隐藏活动工作表外的所有工作表

    Dim sht As Worksheet

    For Each sht In Worksheet

       If sht.Name <> ActiveSheet.Name Then

          sht.Visible = xlSheetVeryHidden '深度隐藏，不能通过“格式”菜单显示它

       End If

    Next

End Sub

 

批量新建工作表 

Sub shtAdd()

   '一张成绩表中保存不同班级的数据，需要以班级名命名

    '根据C列的班级名新建不同的工作表

    Dim i As Integer, sht As Worksheet

    i = 2

    Set sht = Worksheets("成绩表")

    Do While sht.Cells(i, "C") <> ""

       Worksheets.Add after:=Worksheets(Worksheets.Count)

       ActiveSheet.Name = sht.Cells(i, "C").Value

       i = i + 1

    Loop

End Sub

 

批量对数据分类 

Sub fenLei()

    '把成绩按班级分到各个工作表中

    Dim i As Long, bj As String, rng As Range

    i = 2

    bj = Cells(i, "C").Value

    Do While bj <> ""

       '将分表中A列第一个空单元格赋给rng

       Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)

       Cells(i, "A").Resize(1, 7).Copy rng '将记录赋值到对应的工作表中

       i = i + 1

       bj = Cells(i, "C").Value

    Loop

End Sub

 

清除工作表内容

Sub shtClear()

    Dim sht As Worksheet

    For Each sht In Worksheets

       If sht.Name <> "成绩表" Then

          sht.Range("A2:G65536").ClearContents

       End If

    Next

End Sub

 

将工作表保存为新工作簿 

Sub SaveToFile()

   '把各个工作表以单独的工作簿文件保存在本工作簿所在的文件夹下的“班级成绩表”文件夹下

   Application.ScreenUpdating = False '关闭屏幕更新

    Dim folder As String

    folder = ThisWorkbook.Path & "\班级成绩表"

    '如果文件夹不存在，则新建文件夹

    If Len(Dir(folder, vbDirectory)) = 0 Then mkdir folder

    Dim sht As Worksheet

    For Each sht In Worksheets

       sht.Copy

       ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"

       ActiveWorkbook.Close

    Next

   Application.ScreenUpdating = True

End Sub

 

换种写法：

Sub 自动拆分工作表()

            '把各个工作表以单独的工作簿文件保存在本工作簿所在的文件夹下的“拆分工作簿”文件夹下

   Application.ScreenUpdating = False '关闭屏幕更新

    Dim folder As String

    folder = Application.ActiveWorkbook.Path & "\拆分工作簿"

    'folder = ThisWorkbook.Path & "\拆分工作簿"

    '如果文件夹不存在，则新建文件夹

    If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder

    Dim sht As Worksheet

    For Each sht In Worksheets

       sht.Copy

       ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"

       ActiveWorkbook.Close

    Next

   Application.ScreenUpdating = True   

End Sub

 

快速合并多表数据 

Sub HeBing()

   '把各班级成绩表合并到“总成绩”工作表中

    Rows("2:25536").Clear '删除原有记录

    Dim sht As Worksheet, xrow As Integer, rng As Range

    For Each sht In Worksheets  '遍历工作簿中所有工作表

       If sht.Name <> ActiveSheet.Name Then

           Set rng = Range("A65536").End(xlUp).Offset(1, 0) '获得A列第一个空单元格

           xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '记录分表中记录条数

          sht.Range("A2").Resize(xrow, 7).Copy rng '粘贴记录到汇总表

       End If

    Next

End Sub

 

汇总同文件夹下多个工作簿数 

Sub HzwWb()

          '把目前下各个工作簿的信息汇总到同文件夹下的另一个工作簿的同一张工作表里

    Dim r, c As Long

    r = 1 '表头的行数

    c = 8 '表头的列数

    Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清空汇总表中原数据

   Application.ScreenUpdating = False '关闭屏幕更新

    Dim FileName As String, wb As Workbook, sht As Worksheet, Erow As Long, fn As String, arr As Variant

    FileName = Dir(ThisWorkbook.Path & "\" & "*.xlsx")

    Do While FileName <> ""

       If FileName <> ThisWorkbook.Name Then '判断文件是否是本工作簿

           Erow = Range("A1").CurrentRegion.Rows.Count + 1 '取得汇总表中第一条空行行号

           fn = ThisWorkbook.Path & "\" & FileName

           Set wb = GetObject(fn) '将fn代表的工作簿对象赋给变量

           Set sht = wb.Worksheets(1) '汇总的是第一张工作表

          '将数据表中的记录保存在arr数组里

           arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))

          '将数组arr中的数据写入工作表

          Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

           wb.Close False

       End If

       FileName = Dir '用Dir函数取得其他文件名，并赋值给变量

    Loop

   Application.ScreenUpdating = True '恢复屏幕更新

End Sub

 

为工作表建立目录 

Sub mkdir()

    '为工作簿中所有工作表建立目录

   Rows("2:65536").ClearContents

    Dim sht As Worksheet, irow As Integer

    irow = 2

    For Each sht In Worksheets '遍历工作表

       Cells(irow, "A").Value = irow - 1 '写入序号

       '写入工作表名，并建立超链接

       ActiveSheet.Hyperlinks.Add anchor:=Cells(irow, "B"), Address:="", _

          SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name

           irow = irows + 1 '行号加1

    Next

End Sub