vba实用操做

一、vba制做目录

Sub mulu()
    MsgBox "下面将为工做薄中全部工做表创建目录!"
    Rows("2:65536").ClearContents                    '清除工做表中原有数据
    Dim sht As Worksheet, irow As Integer
    irow = 2                                         '在第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

二、合并工做表格数据到第一个工做表

Option Explicit
Sub hebing()
    MsgBox "下面将把各班成绩表合并到“总成绩”工做表中!"
    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)    '得到汇总表A列第一个空单元格
            xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '得到分表中的记录条数
            sht.Range("A2").Resize(xrow, 7).Copy rng            '粘贴记录到汇总表
        End If
    Next
End Sub

三、设置单元格格式

Option Explicit

Sub FontSet()
    With Range("A1:L1").Font
         .Name = "宋体"                                  '设置字体为宋休
         .Size = 12                                      '设置字号为12号
         .Color = RGB(255, 0, 0)                         '设置字体颜色为红色
         .Bold = True                                    '设置字体加粗
         .Italic = True                                   '设置文字倾斜显示
         .Underline = xlUnderlineStyleDouble             '给文字添加单下划线
    End With
End Sub

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

Sub BorderSet()
    With Range("A1").CurrentRegion.Borders
        .LineStyle = xlContinuous                  '设置单线边框
        .Color = RGB(0, 0, 255)                    '设置边框的颜色为蓝色
        .Weight = xlHairline                       '设置边框线条样式
    End With
End Sub

四、汇总同一文件夹下全部的工做簿

Sub HzWb()
    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    ' 判断文件是不是本工做簿
            Erow = Range("A1").CurrentRegion.Rows.Count + 1    ' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName
            Set wb = GetObject(fn)    ' 将fn 表明的工做簿对象赋给变量
            Set sht = wb.Worksheets(1)    ' 汇总的是第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