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

概述：

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

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
    Next
End 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
    Loop
End 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
    Loop
End 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
    Loop
End Sub

清除分表的数据

Sub shtClear()

    Dim sht As Worksheet
    For Each sht In Worksheets
        If sht.Name <> "成绩表" Then              '除了成绩表其它表全部清除
            sht.Range("A1:G65536").ClearContents
        End If
    Next
End 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
    Next
End 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
    Next

End Sub