Mac版Office 365 Excel VBA：多列成绩求和达标后跨表复制求助

原有代码问题梳理 #

• 输出工作表赋值错误：误将目标工作表ws2也指向了Sheet1，无法实现数据迁移到Sheet2的需求
• 语法拼写错误：EnColumn D(xlUp) 属于拼写错误，正确写法为End(xlUp)
• 阈值判断不匹配：需求为求和≥250，原有代码写为>250
• 功能逻辑缺失：未实现A列对应成绩与D、F、H列所有成绩的组合匹配，仅遍历了同一行的成绩计算，不符合跨行列组合的需求

适配实现代码 #

Sub 成绩组合筛选()
    ' 声明变量，适配Mac Office 365 VBA语法
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRowA As Long, lastRowD As Long, lastRowF As Long, lastRowH As Long
    Dim nextRow2 As Long
    Dim i As Long, j As Long, k As Long, l As Long
    Dim totalScore As Long
    
    ' 初始化工作表对象
    Set wb = ThisWorkbook
    Set ws1 = wb.Worksheets("Sheet1")
    Set ws2 = wb.Worksheets("Sheet2")
    
    ' 获取各成绩列的最大有效行号，排除空行
    lastRowA = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRowD = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row
    lastRowF = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    lastRowH = ws1.Cells(ws1.Rows.Count, "H").End(xlUp).Row
    
    ' 获取Sheet2的首个空行位置
    nextRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
    ' 若Sheet2为空，从第1行开始写
    If nextRow2 = 2 And ws2.Cells(1, "A") = "" Then nextRow2 = 1
    
    ' 四层循环遍历所有成绩组合：A列成绩 + 所有D列成绩 + 所有F列成绩 + 所有H列成绩
    For i = 1 To lastRowA
        For j = 1 To lastRowD
            For k = 1 To lastRowF
                For l = 1 To lastRowH
                    ' 计算当前组合的总分
                    totalScore = ws1.Cells(i, "B").Value + ws1.Cells(j, "D").Value + ws1.Cells(k, "F").Value + ws1.Cells(l, "H").Value
                    ' 判断是否达标
                    If totalScore >= 250 Then
                        ' 写入对应姓名和成绩到Sheet2
                        ws2.Cells(nextRow2, "A") = ws1.Cells(i, "A").Value
                        ws2.Cells(nextRow2, "B") = ws1.Cells(i, "B").Value
                        ws2.Cells(nextRow2, "C") = ws1.Cells(j, "C").Value
                        ws2.Cells(nextRow2, "D") = ws1.Cells(j, "D").Value
                        ws2.Cells(nextRow2, "E") = ws1.Cells(k, "E").Value
                        ws2.Cells(nextRow2, "F") = ws1.Cells(k, "F").Value
                        ws2.Cells(nextRow2, "G") = ws1.Cells(l, "G").Value
                        ws2.Cells(nextRow2, "H") = ws1.Cells(l, "H").Value
                        ' 空行指针下移
                        nextRow2 = nextRow2 + 1
                    End If
                Next l
            Next k
        Next j
    Next i
    
    ' 释放对象
    Set wb = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    
    MsgBox "筛选完成，共导出" & nextRow2 - 1 & "条达标组合", vbInformation, "操作完成"
End Sub

使用说明 #

• 运行前请确保工作簿已存在Sheet1和Sheet2两个工作表
• Sheet1中数据严格按照列头规则填写，不要出现成绩列空值导致的计算错误
• 该代码完全适配Mac版Office 365 Excel的VBA运行环境，无Windows专属API调用

内容的提问来源于stack exchange，提问作者Jason McCoy