VBA常见示例题-1

一、答题要求：

1.简答题，请直接将你的代码，写在每个题后面

2.实践题，请将代码写在Macro.xlsm文件上，并按一下方式存储代码

3.代码中sub、function、变量等，不允许使用中文

4.注意代码规范，包括变量命名、代码缩进、代码注释等，不按规范的统一打回调整

5.请勿移动试题打包的所有文件，如需获取” 试题四测试文件.txt”文件数据，代码中文件路径请以ThisWorkbook.Path & “\试题四测试文件.txt”类似方式拼接使用

二、简答题：

1） 请使用至少三种方法，输出一个表有多少行数据，简要说明下你对各种方式的理解

①	ThisWorkbook.Sheets("工作表名").Range("A" & Sheets("工作表名").Rows.Count).End(xlUp).row
从指定位置内获取边界:获取A列行数据,在excel最大值区间范围内从下往上找到边界行数
②	ThisWorkbook.Sheets(“工作表名”).UsedRange.Rows.cout
返回当前区域,即以空行和空列的组合为边界的区域
③	ThisWorkbook.Sheets(“工作表名”).Range(“A1”).CurrentRegion.Rows.cout
返回当前工作表中已使用的单元格围成的矩形区域，不管该区域中是否有空行，空列，或空单元格

2） 给定一个sheet对象，输出该sheet对象的最大行数、最大列数

①	最大行数：ThisWorkbook.Sheets("工作表名").Range("A" & Sheets("工作表名").Rows.Count).End(xlUp).row
②	最大列数：ThisWorkbook.Sheets("工作表名").Range("A1").End(xlToRight).Column

3） 请使用一条代码，打开一个word文件（文件路径为"D:\Test.docx"）

Workbooks.open(“D:\Test.docx”)

4） 已知一个二维数组arr，输出该数组一维、二维的最大下标

Debug.print UBound(arr)
Debug.print UBound(arr(0))

5） 以“月日年 时分秒”格式(如03182022 103045)输出当前时间

Debug.Print Application.Text(Now(), "MMddyyyy hhmmss")
Debug.Print Format(Now(), "MMddyyyy hhmmss")

6） 假设当前日期变量vDate，请使用一条代码输出该变量上一个月份的最后一天日期（如vDate=”2022-03-10”，则输出2022-02-28）

vDate=”2022-03-10”，则输出2022-02-28）
Debug.Print CDate(vDate) - Day(vDate)
Debug.Print DateSerial(Year(vDate), Month(vDate), 0)

7） 已知一个一维数组arr(1 to 8)，请使用代码将数组内容填写在表sht的A1:A8单元格中

①	For i = 1 To UBound(arr)
       Sht.Range("A" & i) = arr(i)
    Next
②	For i = 1 To UBound(arr)
       arr(i) = i
    Next
Range("a1:a" & UBound(arr)) = Application.Transpose(arr)

8） 在excel文件中，如何实现鼠标点击任意单元格，程序弹框Msgbox提示框，输出当前单元格的内容

①	Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        MsgBox Selection.Value
    End Sub

9） 不运行程序，请说出以下程序执行test1后a,b,c的值各是多少，并说明输出结果的缘由

Sub test1()

  Dim a%, b%, c%
    
  a = 2: b = 4: c = 6

  Call test2(a, b, c)

End Sub

Sub test2(a As Integer, ByVal b As Integer, ByRef c As Integer)

  a = 20

  b = 40

  c = 60

End Sub
结果为：a = 20; b=4; c=60

10）请用三种方式，判断字符串strA是否包含字符串strB

	①Debug.Print InStr(strA,strB)    大于0表示包含,否则包含
	②Debug.Print strA Like "*strB*"  True表示包含，False表示不包含
	③Debug.Print strA.IndexOf(strB) 大于0表示包含，-1代表不包含

三、实践题：

1） 参考Macro.xlsm文件的” 试题1_数据排序”sheet，请将A列的数据进行升序排序，将排序后的结果填到B列

1. 要求：

• a) 不可以使用Excel上自带的排序功能

• b) 给的样例数据A列数字个数只写了10个，代码实现时不能固定死，需要动态读取A列的数据个数

'试题1_数据排序-不带排序功能
Sub MainTest2()
    Dim wb As Workbook, sht As Worksheet, rRows As Integer, beforeArr As Variant, I As Integer, j As Integer, Number As Integer
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题1_数据排序")
    rRows = sht.Range("A1").CurrentRegion.Rows.Count
    beforeArr = sht.Range("A1:A" & rRows)
    ReDim afterArr(1 To UBound(beforeArr), 1 To 1)
    For I = 1 To UBound(beforeArr)
        Number = 0
        For j = 1 To UBound(beforeArr)
            If beforeArr(I, 1) - beforeArr(j, 1) > 0 Then
                Number = Number + 1
            End If
        Next
        afterArr(Number + 1, 1) = beforeArr(I, 1)
    Next
    sht.Range("B1:B" & rRows) = afterArr
End Sub

2） 给定文件夹“试题二测试文件夹“，将该文件夹中所有后缀为xlsx的文件名，输出到Macro.xlsm文件的” 试题2_变量文件夹”表中

1. 要求：必须使用两种方法，一种方法不得分，方法一的结果输出到A列，方法二输出到B列

'试题2_变量文件夹-方法1-Dir对象
Sub MainTest2_1()
    Dim fileName As String, folder As String, sht As Worksheet, i As Integer, wb As Workbook
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题2_变量文件夹")
    folder = wb.Path & "\" & "试题二测试文件夹\"
    fileName = Dir(folder & "*.xlsx")
    i = 2
    Do While fileName <> ""
        sht.Range("A" & i) = folder & fileName
        fileName = Dir
        i = i + 1
    Loop
End Sub

'试题2_变量文件夹-方法2-Scripting.FileSystemObject(只获取指定目录下的文件)
Sub MainTest2_2()
    Dim fileName As Variant, folder As String, sht As Worksheet, i As Integer, wb As Workbook
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题2_变量文件夹")
    folder = wb.Path & "\" & "试题二测试文件夹\"
    i = 2
    With CreateObject("Scripting.FileSystemObject").GetFolder(folder)
        For Each fileName In .Files
            Debug.Print fileName.Name
            If fileName Like "*.xlsx" Then
                sht.Range("B" & i) = fileName
                i = i + 1
            End If
        Next
    End With
End Sub

3） 请编写程序，将Macro.xlsm文件的” 试题3_原数据”表序号为偶数的数据行全部删除，同时将剩余数据中年龄大于30的员工ID单元格背景颜色标记为红色(vbred)

1. 注：每次测试运行完，可从“试题3_原数据备份“表还原数据

'练习3
Sub MainTest3()
    Dim wb As Workbook, sht As Worksheet, copySht As Worksheet, iRows As Integer, rng As Range, i As Integer
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题3_原数据")
    Set copySht = wb.Sheets("试题3_原数据备份")
    sht.Cells.Clear
    copySht.Cells.Copy sht.Cells
    iRows = sht.Range("A1").CurrentRegion.Rows.Count
    For i = iRows To 2 Step -1
        If CInt(sht.Range("A" & i)) Mod 2 = 0 Then
            sht.Rows(i).Delete
        ElseIf CInt(sht.Range("C" & i)) > 30 Then
            sht.Range("C" & i).Interior.ColorIndex = 3
        End If
    Next
End Sub

4） 给定txt文件” 试题四测试文件.txt”，请将txt中数据读取写入到Macro.xlsm的“试题4_Txt解析“sheet，注意需要将txt中微信/支付宝交易号、交易金额对应的填到A列、B列

'练习4-方法1-Workbooks.OpenText
Sub MainTest4_1()
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet, txtFileName As String, sht1 As Worksheet
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题4_Txt解析")
    txtFileName = ThisWorkbook.Path & "\试题四测试文件.txt"
    Workbooks.OpenText fileName:=txtFileName, Space:=True
    Set sht1 = ActiveWorkbook.Sheets("试题四测试文件")
    sht1.Range("A2:B" & sht1.Range("A1").CurrentRegion.Rows.Count).Copy sht.Range("A2")
    ActiveWorkbook.Close (False)
    Application.ScreenUpdating = True
End Sub

'练习4—方法2-CreateObject("Scripting.FileSystemObject").OpenTextFile()
Sub MainTest4_2()
    Dim wb As Workbook, sht As Worksheet, txtFileName As String, fso As Object, txtContents As String, txtArr As Variant, i As Integer
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题4_Txt解析")
    txtFileName = ThisWorkbook.Path & "\试题四测试文件.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    txtContents = fso.OpenTextFile(txtFileName).ReadAll
    txtArr = Split(txtContents, Chr(10))
    For i = 1 To UBound(txtArr)
        sht.Range("A" & i + 1) = Split(txtArr(i), Chr(32))(0)
        sht.Range("B" & i + 1) = Split(txtArr(i), Chr(32))(1)
    Next
End Sub

5） 请先在Macro.xslm文件的”试题5_邮件配置”设定好收件人、抄送人、邮件主题、邮件正文，再编写程序，以个人邮箱账号发送一封邮件，需要将” 试题五邮件附件”文件夹中测试邮件附件一.xlsx、测试邮件附件二.docx两个文件做为附件发送

'练习题5-发送outlook邮件-需要引用Microsoft outlook * Object Library
Sub MainTest5()
    Dim myOLApp As Object, objMail As Object, wb As Workbook, sht As Worksheet, folder As String, iRows As Integer, i As Integer
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题5_邮件配置")
    folder = ThisWorkbook.Path & "\试题五邮件附件\"
    Set myOLApp = CreateObject("Outlook.Application")
    Set objMail = myOLApp.CreateItem(olMailItem)
    iRows = sht.Range("A1").CurrentRegion.Rows.Count
    With objMail
        For i = 1 To iRows
            If sht.Range("A" & i).Value = "收件人：" Then
                .To = sht.Range("B" & i).Value
            ElseIf sht.Range("A" & i).Value = "抄送人：" Then
                .CC = sht.Range("B" & i).Value
            ElseIf sht.Range("A" & i).Value = "主题：" Then
                .Subject = sht.Range("B" & i).Value
            ElseIf sht.Range("A" & i).Value = "正文：" Then
                .Body = sht.Range("B" & i).Value
            End If
        Next
        .Attachments.Add folder & "测试邮件附件一.xlsx"
        .Attachments.Add folder & "测试邮件附件二.docx"
        .Send
    End With
End Sub

6） 代码实现，将“试题六测试图片.png“图片插入到Macro,xlsm文件的” 试题6_图片处理”表A1单元格，并将图片填充满A1单元格(调好对应高度、宽度)

'练习题6
Sub MainTest6()
    Dim wb As Workbook, sht As Worksheet, fileName As String
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题6_图片处理")
    fileName = ThisWorkbook.Path & "\试题六测试图片.png"
    With sht.Pictures.Insert(fileName)
        .ShapeRange.LockAspectRatio = msoFalse '取消图片纵横比锁定
        .Placement = xlMoveAndSize            '设置图片的大小和位置随单元格而变
        .ShapeRange.Left = Range("A1").Left  '设置所插入图片的左边界位置
        .ShapeRange.Top = Range("A1").Top    '设置所插入图片的上边界位置
        .ShapeRange.Height = Range("A1").Height '设置所插入图片的高度与单元格的高度相等
        .ShapeRange.Width = Range("A1").Width  '设置所插入图片的宽度与单元格的宽度相等
    End With
End Sub

7） 请使用两种方法，判断一个工作簿(wb)是否存在指定名称(strSheetName)的sheet

'练习题7-方法1
Sub MainTest7_1()
    Dim wb As Workbook, sht As Worksheet, strSheetName As String, bl As Boolean
    Set wb = Workbooks(ThisWorkbook.Name)
    strSheetName = "halo"
    bl = False
    For Each sht In wb.Worksheets
        If sht.Name = strSheetName Then
            bl = True
            Exit For
        Else
            bl = False
        End If
    Next
    If bl Then
        Debug.Print "存在！"
    Else
        Debug.Print "不存在！"
    End If
End Sub

'练习题7-方法2-字典
Sub MainTest7_2()
    Dim wb As Workbook, sht As Worksheet, dic As Object, strSheetName As String
    Set wb = Workbooks(ThisWorkbook.Name)
    strSheetName = "试题6_图片处理"
    Set dic = CreateObject("Scripting.Dictionary")
    For Each sht In wb.Worksheets
        dic(sht.Name) = ""
    Next
    If dic.exists(strSheetName) Then
        Debug.Print "存在！"
    Else
        Debug.Print "不存在！"
    End If
End Sub

8） 请编写程序，将Macro.xlsm文件” 试题8_工时诊疗人次”的总门诊人次、总出诊时长，按医生工号关联填到” 试题8_门诊日志明细”的总门诊人次、总出诊时长列；如果医生工号在” 试题8_门诊日志明细“中，则将该医生的最后出诊时间(就诊日期&就诊时间最大值)填到” 试题8_工时诊疗人次”的最后出诊时间列

1. 要求：

• a) 尽可能使用字典进行处理，不可以使用双层循环匹配的方式
• b) 所有需使用的字段，如” 试题8_工时诊疗人次”的医生工号在C列，代码中尽量不使用C列、第3列等方式读取数据，而采用标题名称”医生工号“来动态识别，避免表格随时列位置随时变动带来的代码修改

'练习题8
Sub MainTest8_1()
    Dim wb As Workbook, dic As Object, i As Integer, filterRows As Integer, dynamicAddress As String, dynamicAddress1 As String
    Dim sht As Worksheet  '试题8_门诊日志明细sheet
    Dim sht1 As Worksheet '试题8_工时诊疗人次sheet
    Dim rng As Range, iRows As Integer, rngAddress As String
    Dim rng1 As Range, iRows1 As Integer, rngAddress1 As String
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("试题8_门诊日志明细")
    Set sht1 = wb.Sheets("试题8_工时诊疗人次")
    Set dic = CreateObject("Scripting.Dictionary")
    iRows = sht.Range("A1").CurrentRegion.Rows.Count
    iRows1 = sht1.Range("A1").CurrentRegion.Rows.Count
    
    Call timeSort(sht, iRows, getColumnCode("就诊日期", sht), getColumnCode("就诊时间", sht), getColumnCode("医生工号", sht)) '就诊日期-就诊时间升序排序
    
    rngAddress = getColumnCode("医生工号", sht)
    rngAddress1 = getColumnCode("医生工号", sht1)
    i = 2
    '填写总门诊人次和总出诊时长
    For Each rng In sht.Range(rngAddress & "2:" & rngAddress & iRows)
        sht1.Range(rngAddress1 & "1:" & rngAddress1 & iRows1).AutoFilter
        sht1.Range(rngAddress1 & "1:" & rngAddress1 & iRows1).AutoFilter field:=1, Criteria1:=rng.Value
        filterRows = sht1.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        If filterRows > 1 Then
            dynamicAddress = getColumnCode("总门诊人次", sht)
            dynamicAddress1 = getColumnCode("总门诊人次", sht1)
            sht.Range(dynamicAddress & i) = sht1.Range(dynamicAddress1 & filterRows)
            dynamicAddress = getColumnCode("总出诊时长", sht)
            dynamicAddress1 = getColumnCode("总出诊时长", sht1)
            sht.Range(dynamicAddress & i) = sht1.Range(dynamicAddress1 & filterRows)
        Else
            sht.Range("E" & i) = "医生工号未筛选到！总门诊人次为空"
            sht.Range("F" & i) = "医生工号未筛选到！总出诊时长为空"
        End If
        sht1.Range(rngAddress1 & "1:" & rngAddress1 & iRows1).AutoFilter
        i = i + 1
    Next
    i = 2
    '填写最后出诊时间
    For Each rng1 In sht1.Range(rngAddress1 & "2:" & rngAddress1 & iRows1)
        sht.Range(rngAddress & "1:" & rngAddress & iRows).AutoFilter
        sht.Range(rngAddress & "1:" & rngAddress & iRows).AutoFilter field:=1, Criteria1:=rng1.Value
        filterRows = sht.UsedRange.SpecialCells(xlCellTypeLastCell).Row
        If filterRows > 1 Then
            dynamicAddress = getColumnCode("最后出诊时间", sht1)
            sht1.Range(dynamicAddress & i) = sht.Range("B" & filterRows) & "&" & sht.Range("C" & filterRows)
        Else
            sht1.Range(dynamicAddress & i) = "医生工号未筛选到！最后出诊时间为空"
        End If
        sht.Range(rngAddress & "1:" & rngAddress & iRows).AutoFilter
        i = i + 1
    Next
End Sub

'动态根据关键字列得到列号
Function getColumnCode(keyName As String, sht As Worksheet)
    getColumnCode = Split(sht.Cells.Find(keyName, lookat:=xlWhole).Address(1, 0), "$")(0)
End Function

'时间排序
Sub timeSort(sht As Worksheet, iRows As Integer, column1 As String, column2 As String, column3 As String)
    sht.Sort.SortFields.Clear
    sht.Sort.SortFields.Add2 Key:=Range(column1 & "2:" & column1 & iRows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    sht.Sort.SortFields.Add2 Key:=Range(column2 & "2:" & column2 & iRows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With sht.Sort
        .SetRange Range(column1 & "1:" & column3 & iRows)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

9） 请将“试题九原数据.xlsx“文件的数据，按站点、实际承运公司汇总含税金额，填到” 测试题9_结果表&配置表”的” 十货站客机腹舱开票明细”中。

1. 注：数据汇总时需要做两次转化

• a) 需要将原数据A列的航站，与” 测试题9_结果表&配置表”E列三字代码匹配转化为F列站点，与结果表G列的对应

• b) 需要将原数据D列实际承运分公司，与” 测试题9_结果表&配置表”A 列匹配转化为B列承运公司，与结果表第二行的对应

'练习题9-方法1
Sub MainTest9()
    Dim wb As Workbook, sht As Worksheet, fileName As String, wb1 As Workbook, sht1 As Worksheet, iRows As Long, dynamicAddress As String, dynamicAddress1 As String, iRows1 As Long
    Dim dict As Object, dict1 As Object, rng As Range, rng1 As Range, totalMoney As Double, rng2 As Range, i As Integer, dict3 As Object, j As Long
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Sheets("测试题9_结果表&配置表")
    fileName = ThisWorkbook.Path & "\试题九原数据.xlsx"
    Set wb1 = Workbooks.Open(fileName)
    Set sht1 = wb1.Sheets(1)
    Set dict = CreateObject("scripting.dictionary") '承运公司，实际承运分公司关键字键值
    Set dict1 = CreateObject("scripting.dictionary") '三字代码，站点关键字键值
    Set dict3 = CreateObject("scripting.dictionary") '实际承运分公司,承运公司关键字键值
    dynamicAddress = getColumnCode("实际承运分公司", sht)
    dynamicAddress1 = getColumnCode("承运公司", sht)
    iRows = sht.Range(dynamicAddress & "1").CurrentRegion.Rows.Count
    '承运公司关键字列
    For Each rng In sht.Range(dynamicAddress & "2:" & dynamicAddress1 & iRows)
        If rng(1, 2) <> "" Then
            dict.Add rng(1, 2).Value, rng(1, 1).Value
        End If
    Next
    '实际承运分公司关键字列
    For Each rng In sht.Range(dynamicAddress & "2:" & dynamicAddress1 & iRows)
        If rng(1, 2) <> "" Then
            dict3.Add rng(1, 1).Value, rng(1, 2).Value
        End If
    Next
    dynamicAddress = getColumnCode("三字代码", sht)
    dynamicAddress1 = getColumnCode("站点", sht)
    iRows = sht.Range(dynamicAddress & "1").CurrentRegion.Rows.Count
    '站点关键字列
    For Each rng In sht.Range(dynamicAddress & "2:" & dynamicAddress1 & iRows)
        If rng(1, 2) <> "" Then
            dict1.Add rng(1, 2).Value, rng(1, 1).Value
        End If
    Next
    iRows = sht.Range("G3").CurrentRegion.Rows.Count - 1
    iRows1 = sht1.Range("A65536").End(xlUp).Row
    i = 3
    For Each rng In sht.Range("G3:G" & iRows)
    totalMoney = 0
        If dict1.exists(rng.Value) Then
            For Each rng1 In sht.Range("H2:M2")
                If dict.exists(rng1.Value) Then
                    For j = 2 To iRows1
                        If dict.Item(rng1.Value) = "其他" Then
                            If dict3.exists(sht1.Range(getColumnCode("航站", sht1) & j).Value) And sht1.Range(getColumnCode("航站", sht1) & j).Value <> "其他" Then
                            ElseIf dict1.Item(rng.Value) = sht1.Range(getColumnCode("实际承运分公司", sht1) & j).Value Then
                                totalMoney = totalMoney + sht1.Range(getColumnCode("含税金额", sht1) & j).Value
                            End If
                        ElseIf dict.Item(rng1.Value) = sht1.Range(getColumnCode("航站", sht1) & j).Value And sht1.Range(getColumnCode("含税金额", sht1) & j).Value Then
                            totalMoney = totalMoney + sht1.Range(getColumnCode("含税金额", sht1) & j).Value
                        End If
                    Next
                sht.Range(getColumnCode(rng1.Value, sht) & i).Value = totalMoney
                End If
            Next
            i = i + 1
        End If
    Next
    wb1.Close (False)
End Sub

'动态根据关键字列得到列号
Function getColumnCode(keyName As String, sht As Worksheet)
    getColumnCode = Split(sht.Cells.Find(keyName, lookat:=xlWhole).Address(1, 0), "$")(0)
End Function

10）请将“试题十测试文件夹“中所有文件的数据汇总到” 测试题10_结果表”

1. 要求：

• a) 结果表需按班级、姓名、语文、数学、英语、总分(语文+数学+英语)列顺序进行输出

• b) 输出结果需先按班级升序，再按总分降序进行排序

'练习题10-方法1
Sub MainTest10()
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet, fileName As String, iRows As Integer, wb1 As Workbook, folder As String, iRows1 As Integer, sht1 As Worksheet, rng As Range, dynamicAddress As String, dynamicAddress1 As String, i As Integer
    Set wb = Workbooks(ThisWorkbook.Name)
    Set sht = wb.Worksheets("测试题10_结果表")
    folder = ThisWorkbook.Path & "\试题十测试文件夹\"
    iRows = sht.Range("A1").CurrentRegion.Rows.Count
    sht.Range("A2:F" & iRows + 1).Clear
    fileName = Dir(folder & "*.xls")
    Do While fileName <> ""
        iRows = sht.Range("A1").CurrentRegion.Rows.Count
        Set wb1 = Workbooks.Open(folder & fileName)
        Set sht1 = wb1.Sheets(1)
        iRows1 = sht1.Range("A1").CurrentRegion.Rows.Count
        For Each rng In sht.Range("A1:E1")
            dynamicAddress = getColumnCode(rng.Value, sht)
            dynamicAddress1 = getColumnCode(rng.Value, sht1)
            sht1.Range(dynamicAddress1 & "2:" & dynamicAddress1 & iRows1).Copy sht.Range(dynamicAddress & iRows + 1)
        Next
        wb1.Close (False)
        fileName = Dir
    Loop
    iRows = sht.Range("A1").CurrentRegion.Rows.Count
    For i = 2 To iRows
        sht.Range(getColumnCode("总分", sht) & i) = sht.Range(getColumnCode("语文", sht) & i) + sht.Range(getColumnCode("英语", sht) & i) + sht.Range(getColumnCode("数学", sht) & i)
    Next
    Call scoreSort(sht, iRows, getColumnCode("班级", sht), getColumnCode("总分", sht))
    Application.ScreenUpdating = True
End Sub

'动态根据关键字列得到列号
Function getColumnCode(keyName As String, sht As Worksheet)
    getColumnCode = Split(sht.Cells.Find(keyName, lookat:=xlWhole).Address(1, 0), "$")(0)
End Function

'班级总分排序
Function scoreSort(sht As Worksheet, iRows As Integer, column1 As String, column2 As String)
    sht.Sort.SortFields.Clear
    sht.Sort.SortFields.Add2 Key:=Range(column1 & "2:" & column1 & iRows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    sht.Sort.SortFields.Add2 Key:=Range(column2 & "2:" & column2 & iRows), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortTextAsNumbers
    With sht.Sort
        .SetRange Range(column1 & "1:" & column2 & iRows)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Function

四、数据源模板表下载

1. 资源模板网盘路径如下：
   VBA常见示例题.rar
   提取码：t6vi