第4章常用对象【下】案例

来源：互联网发布：python 依赖注入编辑：程序博客网时间：2024/06/06 02:39

概述：

上一篇就是理论为主上篇，现在实践为主

7、典型的技巧与示例

7.1、创建一个工作簿

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

7.2、判断工作簿是否打开

Sub IsOpen()    '判断“成绩表.xls”工作簿文件是否已经打开    Dim i As Integer     '定义循环变量    For i = 1 To Workbooks.Count     '循环所有工作簿        If Workbooks(i).Name = "成绩表.xls" Then                    MsgBox "文件已经打开！"            Exit Sub                     '如果找到就是退出过程        End If        Next i    MsgBox "文件没有打开！"End Sub

7.3、判断工作簿是否存在

Sub TestFile()    '判断工作簿所在的文件夹中是否存在“员工花名册.xls”    Dim fil As String    '定义变量    fil = ThisWorkbook.Path & "\bicycle.xls"        'Dir(fil) 如果存在对应文件，将会返回文件的名称，    'len() 表计算字符串测长度,有值那么长度不为0    If Len(Dir(fil)) > 0 Then        MsgBox "工作簿已经存在"    Else        MsgBox "工作簿不存在"    End If    End Sub

当然判断不一定判断工作簿文件类型，例如txt，其它格式也可以判断

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

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里        arr = Array(xrow - 1, "往前的娘娘", "男", "1999-01-01", "2017-01-01", "17年新招")        '这也说明数组第n-1元素对应单元格为n        .Cells(xrow, 1).Resize(1, 6) = arr  '将数组写入单元格区域            End With        ActiveWorkbook.Close savechanges:=True  '关闭工作簿，并保存修改    End Sub

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

Sub shtVisible()    '隐藏活动工作表外的所有工作表    Dim sht As Worksheet        For Each sht In Worksheets        If sht.Name <> ActiveSheet.Name Then            sht.Visible = xlSheetVeryHidden   '深度隐藏        End If    NextEnd Sub

7.6、批量新建工作表

Sub shtadd()    '根据C列的班级名新建不同的工作表    Dim i As Integer, sht As Worksheet    i = 2                                '第一条记录行号为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    LoopEnd Sub

如果出现重复班级怎么办？

Sub shtadd()    '根据C列的班级名新建不同的工作表    Dim i As Integer, sht As Worksheet    i = 2                                '第一条记录行号为2    Set sht = Worksheets("成绩表")    Do While sht.Cells(i, "C") <> ""      '定义循环条件        On Error Resume Next     '出现错误接着下一行        If Worksheets(sht.Cells(i, "C").Value) Is Nothing Then  '判断工作表是否存在            Worksheets.Add after:=Worksheets(Worksheets.Count)            ActiveSheet.Name = sht.Cells(i, "C").Value        End If        i = i + 1    LoopEnd Sub

7.7、批量对数据分类

Sub sort()    '把成绩表按班级分别各个工作表中    Dim i As Long, bj As String, rng As Range    i = 2    bj = Worksheets("成绩表").Cells(i, "C").Value    Do While bj <> ""        '将分表中A列第一个空单元格赋给rng        Set rng = Worksheets(bj).Range("A65536").End(xlUp)        If rng.Value <> "" Then            Set rng = rng.Offset(1, 0)        End If        Worksheets("成绩表").Cells(i, "A").Resize(1, 7).Copy rng '将记录复制到相应的工作表中        i = i + 1        bj = Worksheets("成绩表").Cells(i, "C").Value    LoopEnd Sub

清除分表的数据

Sub shtClear()    Dim sht As Worksheet    For Each sht In Worksheets        If sht.Name <> "成绩表" Then              '除了成绩表其它表全部清除            sht.Range("A1:G65536").ClearContents        End If    NextEnd Sub

7.8、将工作表保存为新的工作簿

如果copy出现1004异常，参考：点击打开链接

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       If sht.Visible = True Then          sht.Copy          ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xls"          ActiveWorkbook.Close        End If    Next    Application.ScreenUpdating = True            '开启屏幕更新End Sub

7.9、快速合并多表数据

Sub hebing()    '把各班级成绩表合并到“总成绩”工作表中    Rows("2:65536").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)    '获取总表的数据            xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '获取最后一行            sht.Range("A2").Resize(xrow, 7).Copy rng            '将数据复制给总表        End If    NextEnd Sub

7.10、汇总同文件夹下多工作簿数据

Sub wwb()    Dim bt As Range, r As Long, c As Long    r = 1 '1是表头的行数    c = 8 ' 8是表头的列数    Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清除汇总表原数据    Application.ScreenUpdating = False    Dim filename As String, wb As Workbook, erow As Long, fn As String, arr As Variant    filename = Dir(ThisWorkbook.Path & "\*.xls")    Do While filename <> ""        If filename <> ThisWorkbook.Name Then            MsgBox filename            erow = Range("A1").CurrentRegion.Rows.Count + 1            fn = ThisWorkbook.Path & "\" & filename         '得到文件绝对路径            Set wb = GetObject(fn)                          '获取路径对应的对象            Set sht = wb.Worksheets(1)                      '获取第一个工作表            '将数据表中的记录保存在arr数组里            arr = sht.Range(sht.Cells(r, "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

7.11、为工作表建立目录

Sub mulu()    '为工作簿中所有工作表建立目录    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 = irow + 1 '行号加1    NextEnd Sub