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