簡單套用VBA模板代碼，對(duì)初學(xué)VBA并立志在VBA扎根者來說，或許不是最好的辦法，但對(duì)只需要解決自己一些簡單問題的人來講就是一種捷徑。
*********自定義函數(shù)*********
Function Nows()    '聲明函數(shù)，無參。時(shí)間函數(shù)
    Dim Tim As String    '聲明一個(gè)變量
    Tim = Format(Now, "yyyy-mm-dd hh:mm:ss")    '獲取當(dāng)前時(shí)間，并轉(zhuǎn)換成文本
    Nows = Tim    '將文本日期賦與函數(shù)
End Function
---------------------------------------------------------------------------------------'
Function nows()   '聲明函數(shù)
    Dim tim As String  '聲明一個(gè)變量
    tim = Format(Now, "yyyy-mm-dd hh:mm:ss") '獲取當(dāng)前時(shí)間，并轉(zhuǎn)換成文本
    nows = tim '將文本日期賦予函數(shù)
End Function
----------------------------------------------------------------------------------------
Function 工作簿名()    '獲取當(dāng)前工作簿名稱，無參數(shù)
    工作簿名 = ActiveWorkbook.Name    'ActiveWorkbook即表示當(dāng)前工作簿
End Function
---------------------------------------------------------------------------------------
Function 大寫(cell As String) As String    '聲明函數(shù)名，有一個(gè)參數(shù)
    Dim RMBS As String
    Application.Volatile    '聲明為易失性函數(shù)
    If cell = "" Or Not VBA.IsNumeric(cell) Then 大寫 = "": Exit Function    '如果參數(shù)為空或者非數(shù)值則返回空白
    If cell = 0 Then 大寫 = "零元整": Exit Function    '如果參數(shù)為0則返回“零元整”
    '將數(shù)值轉(zhuǎn)換成中文大寫，并將點(diǎn)替換成“元”，將負(fù)號(hào)替換成“負(fù)”
    RMBS = Replace(Replace(Application.Text(Round(cell, 2), "[DBnum2]"), ".", "元"), "-", "負(fù)")
    '加入角與分,同時(shí)將最后的“零”替換成“元整”
    RMBS = IIf(Left(Right(RMBS, 3), 1) = "元", Left(RMBS, Len(RMBS) - 1) & "角" & Right(RMBS, 1) & "分", IIf(Left(Right(RMBS, 2), 1) = "元", RMBS & "角", IIf(RMBS = "零", "", RMBS & "元整")))
    '將“零元”和“零角”替換成空
    RMBS = Replace(Replace(RMBS, "零元", ""), "零角", "")
    大寫 = RMBS    '將變量的值賦與函數(shù)
End Function
--------------------------------------------------------------------------------------
Function 工作表(Optional 序號(hào)) As String  '聲明函數(shù)，有一個(gè)參數(shù)可選參數(shù).[列號(hào)COLUMN()或行號(hào)ROW()]
    Application.Volatile    '聲明為易失性函數(shù)
''如果未輸入?yún)?shù)，則賦與變量序號(hào)為當(dāng)前表的地址
    If VBA.IsMissing(序號(hào)) Then 序號(hào) = ActiveSheet.Index
    If 序號(hào) > Sheets.Count Then    '如果參數(shù)大于工作表數(shù)量
       工作表 = ""  '返回空
    Else            '否則
       工作表 = Sheets(序號(hào)).Name    '取表名
    End If
End Function
---------------------------------------------------------------------------------------
Function 關(guān)機(jī)(Optional Close_Time As Byte = 10)    '聲明函數(shù)名稱
    關(guān)機(jī) = Close_Time    '在單元格顯示時(shí)間
    Shell "shutdown -s -t " & Close_Time    '在指定的時(shí)間內(nèi)關(guān)閉工作表，調(diào)用的DOS命令
End Function
Function hesum(rng As Range, Optional 單雙 As Byte = 1)    '聲明函數(shù)，有兩個(gè)參數(shù)，第二個(gè)是可選參數(shù)
    Application.Volatile    '聲明為易失性函數(shù)
    Dim cell As Range, Sum1, Sum2
    For Each cell In rng
        If InStr(cell, "/") > 0 Then  '如果有“/”
            左 = CLng(Left(cell, InStr(cell, "/") - 1))  '提取/左邊的數(shù)據(jù)
            右 = CLng(Replace(cell, 左 & "/", ""))  '提取/右邊的數(shù)據(jù)
            Sum1 = Sum1 + (左 + 右)    '將左右相加
        Else
            Sum2 = Sum2 + cell * 2    '沒有“/”則直接乘以2
        End If
    Next
    hesum = (Sum2 + Sum1) / 單雙    '匯總后除以第二參數(shù)
End Function
Function 排名(區(qū)域, 成績)    '聲明函數(shù)，有兩個(gè)參數(shù)
    Application.Volatile    '聲明為易失性函數(shù)
    Dim Dic As Object, rng, i As Integer    '聲明變量，包括一個(gè)字典對(duì)象
    Set Dic = CreateObject("scripting.dictionary")    '聲明字典對(duì)象變量
    For Each rng In 區(qū)域  '遍歷區(qū)域
'如果變量rng等于成績則為變量i賦值1，如果變量rng大于成績則將rng的值追加到字典中
        If rng = 成績 Then i = 1 Else If rng > 成績 Then Dic(rng * 1) = 1
    Next
    '如果變量i大于0,即區(qū)域中有數(shù)據(jù)等于成績，那么排名結(jié)果等于字典中的數(shù)量加1（字典對(duì)象是忽略重復(fù)值的）
    If i > 0 Then 排名 = Dic.Count + 1 Else 排名 = "超出范圍"    '如果成績與區(qū)域中任何不等則返回“超出范圍”
End Function
Function Col(Optional rng As Range, Optional style As String = "A")  '聲明函數(shù)名稱，有兩個(gè)可選參數(shù)
    Application.Volatile    '聲明為易失性函數(shù)
'如果第二參數(shù)錄入A和a以外的任意字符則返回空白
    If style <> "A" And style <> "a" Then Col = "": Exit Function
    If rng Is Nothing Then Set rng = ActiveCell    '如果忽略第一參數(shù)則默認(rèn)取當(dāng)前活動(dòng)單元格
    '函數(shù)結(jié)果等于Cells(1, rng)的地址去除后1之后所對(duì)應(yīng)的字母。然后根據(jù)第二參數(shù)進(jìn)行大小寫控制
    Col = StrConv(Replace(Cells(1, rng.Column).Address(0, 0), 1, ""), IIf(style = "A", vbUpperCase, vbLowerCase))
End Function
----------------------------------------------------------------------------------------
Function 星期(Optional dates As Date, Optional style As Byte = 2)    '聲明函數(shù)名稱，具有兩個(gè)可選參數(shù)
    Application.Volatile    '聲明為易失性函數(shù)
    If dates = 0 Then dates = Date    '如果忽略第一參數(shù)，則以當(dāng)日計(jì)算
'如果僅僅一個(gè)參數(shù)，則第參數(shù)在1到4之間，則將參數(shù)值賦與第二參數(shù)，而將當(dāng)前日期賦與第一參數(shù)
    If dates < 5 And dates > 1 Then style = dates: dates = Date
    Select Case style    '根據(jù)第二參數(shù)值選擇星期的格式
    Case 1    '第二參數(shù)為1
        星期 = WorksheetFunction.Text(dates, "aaa")    '短寫中文
    Case 2
        星期 = WorksheetFunction.Text(dates, "aaaa")    '長寫中文
    Case 3
        星期 = WorksheetFunction.Text(dates, "ddd")    '短寫英文
    Case 4
        星期 = WorksheetFunction.Text(dates, "dddd")    '長寫英文
    End Select
End Function
--------------------------------------------------------------------------------------------
Function Connect(ParamArray rng() As Variant)    '聲明函數(shù)名稱，有多個(gè)可選參數(shù)，包括1到255個(gè)
    Dim cell As Range, celll As Range, i As Integer, cellv As Variant    '聲明變量
    Application.Volatile    '聲明為易失性函數(shù)
    Connect = ""    '將函數(shù)初始化
'遍歷參數(shù)所代碼的對(duì)象集合（可能是字符串，可能是區(qū)域，也可能是數(shù)組）
    For i = 0 To UBound(rng)
        If Not IsMissing(rng(i)) Then    '如果有參數(shù)
            Select Case TypeName(rng(i))    '根據(jù)參數(shù)的類型決定計(jì)算方式
            Case "Range"   '如果是單元格
                '如果參數(shù)設(shè)置過大，僅僅對(duì)參數(shù)與已用區(qū)域的重疊部分進(jìn)行計(jì)算
                Set celll = Application.Intersect(rng(i), ActiveSheet.UsedRange)
                For Each cell In celll  '遍歷單元格區(qū)域
                    Connect = Connect & cell  '串連所有單元格字符
                Next cell
            Case "Variant()"  '如果是數(shù)組（包括內(nèi)存數(shù)組）
                For Each cellv In rng(i)  '遍歷數(shù)組
                    '跳過False，將數(shù)組中其它元素串連
                    If cellv <> False Then Connect = Connect & cellv
                Next cellv
            Case Else  '否則
                Connect = Connect & rng(i)  '直接連接（指直接在參數(shù)中輸入的字符串）
            End Select
        End If
    Next i
End Function
Function Functions(ParamArray rng() As Variant)  '聲明函數(shù)名稱，有多個(gè)可選參數(shù)，包括1到255個(gè)
    Dim cell, Fun_count As Long, i As Byte, celll As Range    '聲明變量
    Application.Volatile    '聲明為易失性函數(shù)
    If UBound(rng) = -1 Then Functions = 0: Exit Function    '如果無參數(shù)則結(jié)果為0
    For i = 0 To UBound(rng)   '遍歷每個(gè)參數(shù)
        If Not IsMissing(rng(i)) Then    '如果有參數(shù)
            Set celll = Application.Intersect(rng(i), ActiveSheet.UsedRange)
            For Each cell In celll    '遍歷區(qū)域中每個(gè)元素
                If cell.HasFormula Then Fun_tion = Fun_tion + 1    '如果有公式則累加變量
            Next cell
        End If
    Next i
    Functions = Fun_tion    '統(tǒng)計(jì)結(jié)果
End Function
Function AverageIfcol(條件區(qū) As Range, 顏色單元格 As Range, Optional 統(tǒng)計(jì)區(qū))    '聲明函數(shù)名稱，有三個(gè)參數(shù)，第三個(gè)是可選參數(shù)
    Dim i As Integer, counts As Integer, rng As Range, sum As Double  '聲明變量
    Application.Volatile    '聲明為易失性函數(shù)
    If IsMissing(統(tǒng)計(jì)區(qū)) Then Set rng = 條件區(qū)  '如果第三參數(shù)被忽略，則將條區(qū)賦與rng變量
'如果未被忽略，那么以統(tǒng)計(jì)區(qū)第一個(gè)單元格為基準(zhǔn)，向下擴(kuò)充到條件區(qū)同等大于的區(qū)域賦與變量Rng
    If Not IsMissing(統(tǒng)計(jì)區(qū)) Then Set rng = 統(tǒng)計(jì)區(qū)(1).Resize(條件區(qū).Rows.Count, 條件區(qū).Columns.Count)
    For i = 1 To 條件區(qū).Count    '遍歷條件區(qū)
        '如果條件區(qū)中某個(gè)單元格背景色與顏色單元格區(qū)域（參照區(qū)）顏色一致，那么
        If 條件區(qū)(i).Interior.Color = 顏色單元格(1).Interior.Color Then
            sum = sum + rng(i).Value  '累加符合條件的數(shù)據(jù)
            counts = counts + 1  '統(tǒng)計(jì)符合條件的個(gè)數(shù)
        End If
    Next i
    AverageIfcol = sum / counts  '最后結(jié)果等于總和除以個(gè)數(shù)
End Function
----------------------------------------------------------------------------------------------
'聲明函數(shù)名稱，有三個(gè)參數(shù)，第三個(gè)是可選參數(shù),函數(shù)的結(jié)果是數(shù)組
Function VlookupCol(查找值 As Range, 查找區(qū)域 As Range, Optional 列數(shù) As Byte = 2) As Variant
    Dim Col As Long, cell As Range, arr(), i As Byte '聲明變量
    Application.Volatile    '聲明為易失性函數(shù)
    Col = 查找值.Interior.Color  '獲取參照單元格的背景色
    '遍歷查找區(qū)域的最左邊一列
    For Each cell In 查找區(qū)域(1).Resize(查找區(qū)域.Rows.Count, 1)
        If cell.Interior.Color = Col Then  '如果與參照顏色一致
            i = i + 1  '累加變量
           ReDim Preserve arr(1 To i)  '重新聲明數(shù)據(jù)大小，且保持?jǐn)?shù)組原數(shù)據(jù)
              arr(i) = cell.Offset(0, 列數(shù) - 1)  '將找到的單元格右邊對(duì)應(yīng)的數(shù)值賦與數(shù)組
        End If
    Next cell
 VlookupCol = WorksheetFunction.Transpose(arr)  '將數(shù)組的結(jié)果賦與函數(shù)
End Function
-----------------------------------------------------------------------------------------------
Function SFZ(cell As Range, Optional Options As String = "XB") As String '提取性別
    Application.Volatile
    Dim temp As String
    If cell = "" Then SFZ = "": Exit Function
    If Len(cell.Text) <> 15 And Len(cell.Text) <> 18 Then SFZ = "": Exit Function
    If Options = "" Or (UCase(Options) <> "NL" And UCase(Options) <> "SR" And UCase(Options) <> "XB") Then SFZ = "": Exit Function
    If UCase(Options) = "XB" Then SFZ = VBA.IIf((Mid(cell.Text, 15, 3) Mod 2), "男", "女"): Exit Function
    If Len(cell.Text) = 15 And Mid(cell.Text, 7, 1) = 0 Then SFZ = "20" & Mid(cell.Text, 7, 2) & "-" & Mid(cell.Text, 9, 2) & "-" & Mid(cell.Text, 11, 2)
    If Len(cell.Text) = 15 And Mid(cell.Text, 7, 1) > 0 Then SFZ = "19" & Mid(cell.Text, 7, 2) & "-" & Mid(cell.Text, 9, 2) & "-" & Mid(cell.Text, 11, 2)
    If Len(cell.Text) = 18 Then SFZ = Mid(cell.Text, 7, 4) & "-" & Mid(cell.Text, 11, 2) & "-" & Mid(cell.Text, 13, 2)
    If UCase(Options) = "NL" Then
        Dim dat As Date
        dat = DateSerial(VBA.Split(SFZ, "-")(0), VBA.Split(SFZ, "-")(1), VBA.Split(SFZ, "-")(2))
        SFZ = Application.Evaluate("DATEDIF(" & dat * 1 & ", NOW()," & """Y""" & ")")
    End If
End Function
Sub 從身份證號(hào)碼獲取信息()
    Dim rng As Range, i As Integer
    Set rng = Application.InputBox("請(qǐng)選擇區(qū)域：", "確定計(jì)算區(qū)域", IIf(TypeName(Selection) = "Range", Selection.Address(0, 0), ""), , , , , 8)
    If rng.Columns.Count > 1 Then MsgBox "不能選擇一列以上", 64, "出錯(cuò)提示": Exit Sub
    If rng(1) = "" Then MsgBox "請(qǐng)選擇身份證號(hào)碼存放區(qū)域", 64, "出錯(cuò)提示": Exit Sub
    Application.ScreenUpdating = False
    For i = 1 To rng.Count
        rng(i).Offset(0, 1) = SFZ(rng(i), "nl")
        rng(i).Offset(0, 2) = SFZ(rng(i), "sr")
        rng(i).Offset(0, 3) = SFZ(rng(i))
    Next i
    Application.ScreenUpdating = True
End Sub
Sub auto_Open()
    On Error Resume Next
    auto_close
    With Application.CommandBars("cell").Controls.Add(msoControlButton, 1, , 3, True)
        .Caption = "批量獲取身份證信息(&P)"
        .OnAction = "從身份證號(hào)碼獲取信息"
        .Style = msoButtonIconAndCaption
        .FaceId = 263
    End With
End Sub
Sub auto_close()
    On Error Resume Next
    Application.CommandBars("cell").Controls("批量獲取身份證信息(P)").Delete
End Sub
-----------------------------------------------------------------------------------------------

*******VBA宏程序********
'Like用法(輸入小寫字母限定宏)
Private Sub TextBox1_Change()
    If Len(TextBox1.Text) > 0 Then
        If Right(TextBox1.Text, 1) Like "[a-z]" Then Exit Sub Else Me.TextBox1 = Left(TextBox1.Text, Len(TextBox1.Text) - 1)
    End If
End Sub

'Private Sub TextBox1_Change()
'    If Len(TextBox1.Text) > 0 Then
'        If Right(TextBox1.Text, 1) Like "[4-8D-G]" Then Exit Sub Else Me.TextBox1 = Left(TextBox1.Text, Len(TextBox1.Text) - 1)
'    End If
'End Sub
-------------------------------------------------------------------------------------------------
Sub 姓名(name As String) '確認(rèn)權(quán)限
    Dim i As Byte, rng As Range
    For i = 1 To Sheets.Count
        If ThisWorkbook.Sheets(i).name = "許可人員列表" Then: GoTo OK
    Next i
    MsgBox "不存在“許可人員列表”", 64
    Exit Sub
OK:
    If Len(name) < 2 Or Len(name) > 4 Then MsgBox "長度只能2到4,請(qǐng)重新錄入", 64: Exit Sub
    Set rng = ThisWorkbook.Sheets("許可人員列表").Range("a1:a10").Find(name)
    If rng Is Nothing Then MsgBox "你無操作權(quán)限" Else MsgBox "你具有操作權(quán)限"
End Sub
Sub 確認(rèn)權(quán)限一() '手工指定姓名
    Call 姓名(Application.InputBox("請(qǐng)輸入您的姓名", "確認(rèn)權(quán)限", "", , , , , 2))
End Sub
Sub 確認(rèn)權(quán)限二() '以當(dāng)前表A1的值進(jìn)行判斷
    Call 姓名(ActiveSheet.Range("A1"))
End Sub
Sub 確認(rèn)權(quán)限三() '以O(shè)FFICE安裝用戶名進(jìn)行判斷
    Call 姓名(Application.UserName)
End Sub
------------------------------------------------------------------------------------------------
Sub 合并三個(gè)班成績到總表()
    Dim sht As Worksheet '聲明變量
    Sheets("匯總表").Select
    For Each sht In Sheets  '遍歷所有工作表
        If sht.Name <> ActiveSheet.Name Then  '如果sht的名字不等于當(dāng)前表名字
           '如果工作表A列非空（本程序要求工作表的數(shù)據(jù)必須從A列開始存放）
            If WorksheetFunction.CountA(sht.[a:a]) > 0 Then
            '將工作表sht中A1到最后一個(gè)非空行之間的所有行復(fù)制到當(dāng)前表的從上到下第一個(gè)空行
                sht.[a1].Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row, Columns.Count).Copy _
                ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(Len([a1]) > 0, 0)
            End If

        End If
    Next sht  '復(fù)制下一個(gè)
End Sub
------------------------------------------------------------------------------------------------
Sub 復(fù)制數(shù)據(jù)() '從Sheet2復(fù)制數(shù)據(jù)到當(dāng)前工作表空白區(qū)域中
    With Sheet2.UsedRange    'With減少對(duì)象的引用次數(shù)
'利用Offset取得當(dāng)前表已用區(qū)域之后第一個(gè)空白單元格，配合Resize將區(qū)域重置為與Sheet2標(biāo)題以外的數(shù)據(jù)一樣大小
'然后將兩個(gè)相同大小的區(qū)域直接賦值即可。但在賦值時(shí)需要注意一個(gè)問題：Value不能省略
        ActiveSheet.UsedRange.Cells(1, 1).Offset(ActiveSheet.UsedRange.Rows.Count).Resize(.Rows.Count - 2, .Columns.Count) = .Offset(2, 0).Resize(.Rows.Count - 2, .Columns.Count).Value
    End With
    ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous    '對(duì)已用區(qū)域添加邊框
End Sub
-------------------------------------------------------------------------------------------------
Sub 隔一行插入N行()
    Application.ScreenUpdating = False '關(guān)閉屏幕刷新
    Dim i As Integer, Row_Count As Byte '聲明變量
    Row_Count = InputBox("隔行插入幾行？", "確定行數(shù)", 1) '用戶指定插行的行數(shù)
    For i = 20 To 1 Step -1 '從最大值循環(huán)至第一行
        Cells(i, 1).Resize(Row_Count * 1, 1).EntireRow.Insert Shift:=xlDown '插入行
    Next i
    [a1].Resize(Row_Count * 1, 1).EntireRow.Delete '刪除第一行前插入的行
    Application.ScreenUpdating = True '恢復(fù)屏幕更新
End Sub
--------------------------------------------------------------------------------------------------
Sub 工作表減肥()
    MsgBox "減肥前：" & ActiveSheet.UsedRange.Address   '獲取減肥前的已用區(qū)域地址
    '清除多余的列
    Dim Col_Count As Long
    With ActiveSheet.UsedRange  '使用With簡化對(duì)象引用
        For Col_Count = .Columns.Count To 1 Step -1 '從已用區(qū)域最后一列開始，直到第一列
            '如果循環(huán)中某單元格整列皆為空白
            '（Resize方法的作用是使用For只在已用區(qū)域的第一行循環(huán)，忽略其它行，提升代碼效率）
            If WorksheetFunction.CountA(.Item(1).Resize(1, .Columns.Count)(Col_Count).EntireColumn) = 0 Then
                '將該列刪除
                .Item(1).Resize(1, .Columns.Count)(Col_Count).EntireColumn.Delete
            Else '否則
                Exit For '只要該列有一個(gè)數(shù)據(jù)則退出循環(huán)，避免刪除必要的空列
            End If
        Next
    End With
     '清除多余的行
    Dim Row_Count As Long
    With ActiveSheet.UsedRange  '使用With簡化對(duì)象引用
        For Row_Count = .Rows.Count To 1 Step -1 '從已用區(qū)域最后一行開始，直到第一行
            '如果循環(huán)中某單元格整行皆為空白
            '（Resize方法的作用是使用For只在已用區(qū)域的第一列循環(huán)，忽略其它列，提升代碼效率）
            If WorksheetFunction.CountA(.Item(1).Resize(.Rows.Count, 1)(Row_Count).EntireRow) = 0 Then
                '將該列刪除
                .Item(1).Resize(.Rows.Count, 1)(Row_Count).EntireRow.Delete
            Else '否則
                Exit For '只要該列有一個(gè)數(shù)據(jù)則退出循環(huán)，避免刪除必要的空列
            End If
        Next
    End With
endd:
    MsgBox "減肥后：" & ActiveSheet.UsedRange.Address  '報(bào)告減肥后的已用區(qū)域地址
End Sub
------------------------------------------------------------------------------------------------
Sub 數(shù)據(jù)交換()
    Dim rng As Range, adds As String, i As Byte, j As Byte, rngg
    '獲取所有姓名所在地址
    For Each rng In ActiveSheet.UsedRange.Item(1).Resize(1, ActiveSheet.UsedRange.Columns.Count)
        If rng = "姓名" Then adds = adds & rng.Address(0, 0) & ","
    Next rng
    With Range(Left(adds, Len(adds) - 1))
        '統(tǒng)計(jì)組別個(gè)數(shù)
        j = .Areas.Count
        '將最后一個(gè)區(qū)域的值存入內(nèi)存中
        rngg = .Areas(1).CurrentRegion
        For i = 1 To j - 1    '遍歷最后一個(gè)區(qū)或以外的所有區(qū)域
            '將下一個(gè)區(qū)域的值賦于當(dāng)于區(qū)域
            .Areas(i).CurrentRegion = .Areas(i + 1).CurrentRegion.Value
        Next i
        .Areas(j).CurrentRegion = rngg    '再將內(nèi)存中的值賦于最后一個(gè)區(qū)域
    End With
End Sub
-------------------------------------------------------------------------------------------------
Sub 數(shù)據(jù)交換() 'Offset應(yīng)用
    Dim rng As Range, adds As String, i As Byte, j As Byte, rngg
    '獲取所有姓名所在地址
    For Each rng In ActiveSheet.UsedRange.Resize(1, ActiveSheet.UsedRange.Columns.Count)
        If Len(rng) > 0 Then adds = adds & rng.Address(0, 0) & ","
    Next rng
    With Range(Left(adds, Len(adds) - 1))
        '統(tǒng)計(jì)組別個(gè)數(shù)
        j = .Areas.Count
        '將最后一個(gè)區(qū)域的值存入內(nèi)存中,Offset的作用是向下偏移一行，從而避免移動(dòng)標(biāo)題
        rngg = .Areas(1).CurrentRegion.Offset(1)
        For i = 1 To j - 1    '遍歷最后一個(gè)區(qū)或以外的所有區(qū)域
            '將下一個(gè)區(qū)域的值賦于當(dāng)于區(qū)域
            .Areas(i).CurrentRegion.Offset(1) = .Areas(i + 1).CurrentRegion.Offset(1).Value
        Next i
        .Areas(j).CurrentRegion.Offset(1) = rngg   '再將內(nèi)存中的值賦于最后一個(gè)區(qū)域
    End With
End Sub
-------------------------------------------------------------------------------------------------
Sub 數(shù)據(jù)交換()
    Dim rng As Range, adds As String, i As Byte, j As Byte, rngg
    '獲取所有姓名所在地址
    For Each rng In ActiveSheet.UsedRange.Item(1).Resize(1, ActiveSheet.UsedRange.Columns.Count)
        If rng = "姓名" Then adds = adds & rng.Address(0, 0) & ","
    Next rng
    With Range(Left(adds, Len(adds) - 1))
        '統(tǒng)計(jì)組別個(gè)數(shù)
        j = .Areas.Count
        '將最后一個(gè)區(qū)域的值存入內(nèi)存中
        rngg = .Areas(1).CurrentRegion
        For i = 1 To j - 1    '遍歷最后一個(gè)區(qū)或以外的所有區(qū)域
            '將下一個(gè)區(qū)域的值賦于當(dāng)于區(qū)域
            .Areas(i).CurrentRegion = .Areas(i + 1).CurrentRegion.Value
        Next i
        .Areas(j).CurrentRegion = rngg    '再將內(nèi)存中的值賦于最后一個(gè)區(qū)域
    End With
End Sub
-------------------------------------------------------------------------------------------------
Sub 行列自動(dòng)合計(jì)()
    '先匯總各行的值
    For i = 1 To Selection.Rows.Count  '從1到總行數(shù)
    '利用Offset取得匯總數(shù)據(jù)的放置位置，即選區(qū)第一個(gè)單元格向右偏移選區(qū)的列數(shù)
    '合計(jì)區(qū)域也用Offset逐行偏量來獲取，Resize的作用是重置為1行，否則會(huì)匯總其它行的數(shù)據(jù)
    Selection(1).Offset(i - 1, Selection.Columns.Count) = WorksheetFunction.Sum(Selection.Offset(i - 1).Resize(1))
    Next
    '再匯總各列的值
    For i = 1 To Selection.Columns.Count + 1 '從1到總列數(shù)加1,因?yàn)樾枰獙?duì)行的匯總數(shù)再進(jìn)行匯總
    Selection(1).Offset(Selection.Rows.Count, i - 1) = WorksheetFunction.Sum(Selection.Offset(, i - 1).Resize(, 1))
    Next
End Sub
-------------------------------------------------------------------------------------------------
********自動(dòng)宏*********
Option Explicit
'聲明工作表事件
Private Sub Worksheet_Change(ByVal Target As Range)
    '如果只在一個(gè)單元格中編輯數(shù)據(jù)就執(zhí)行事件過程
    If Target.Count = 1 Then
       '使用Cells參數(shù)Columns.Count是為了兼容Excel 2003，Target.Row + 1則表示下一行
        With Cells(Target.Row + 1, Columns.Count).End(xlToLeft)
            '自動(dòng)選擇下一行第一個(gè)非空單元格
            .Offset(0, -(Len(.Text) > 0)).Select
        End With
    End If
End Sub
--------------------------------------------------------------------------------------------------
Sub 批量打開文件()
    Dim fd As FileDialog, Item As Integer
    '彈出一個(gè)瀏覽文件的窗口，可以多選目標(biāo)文件
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    '如果選擇了文件
    If fd.Show = -1 Then
        '遍歷所有文件
        For Item = 1 To fd.SelectedItems.Count
        '逐個(gè)打開文件
         Workbooks.Open (fd.SelectedItems(Item))
        Next Item
    End If
End Sub
--------------------------------------------------------------------------------------------------
Public WithEvents app As Application  '聲明可觸發(fā)事件的對(duì)象變量
Private Sub app_NewWorkbook(ByVal Wb As Workbook)  '聲明應(yīng)用程序事件
    Dim i As Byte
    Wb.Sheets.Add , , 7 - Sheets.Count  '創(chuàng)建4個(gè)工作表（默認(rèn)有3個(gè)）
    Wb.Sheets(1).Name = "總表"  '將第一個(gè)命名為總表
    For i = 2 To Wb.Sheets.Count  '從第二開始　直到最后一個(gè)
        Wb.Sheets(i).Name = "分表" & i - 1  '改名為“分表”加編號(hào)
    Next
End Sub
--------------------------------------------------------------------------------------------------
Private Sub Workbook_BeforePrint(Cancel As Boolean)
    With ActiveSheet.PageSetup  '設(shè)置頁面
        .LeftHeader = "&D"   '頁眉左邊插入日期
        .CenterHeader = ""   '中間空白
        .RightHeader = "第&P頁總&N頁" '右邊顯示頁數(shù)
    End With
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
    With ActiveSheet.PageSetup  '設(shè)置頁面
        .LeftHeader = "&D"   '頁眉左邊插入日期
        .CenterHeader = ""   '中間空白
        .RightHeader = "第&P頁總&N頁" '右邊顯示頁數(shù)
    End With
End Sub
-------------------------------------------------------------------------------------------------
Sub 獲取CD磁盤空間()
MsgBox "C盤:" & String(6, " ") & (CreateObject("SCRIPTING.FILESYSTEMOBJECT").GETDRIVE("C:").TOTALSIZE / 1024) & "MB" & Chr(10) & "D盤:" & String(6, " ") & (CreateObject("SCRIPTING.FILESYSTEMOBJECT").GETDRIVE("D:").TOTALSIZE / 1024) & "MB" & Chr(10) & "E盤:" & String(6, " ") & (CreateObject("SCRIPTING.FILESYSTEMOBJECT").GETDRIVE("E:").TOTALSIZE / 1024) & "MB" & Chr(10) & "F盤:" & String(6, " ") & (CreateObject("SCRIPTING.FILESYSTEMOBJECT").GETDRIVE("F:").TOTALSIZE / 1024) & "MB" & Chr(10)
End Sub