VBA按x*y单元格取均值压缩矩阵行列适配Excel 3D曲面图

原代码核心报错原因 #

• 所有Range对象赋值时遗漏Set关键字，VBA中对象赋值必须使用Set
• 边界计算逻辑错误：获取最后一行/列时使用End(xlDown)遇空行会截断，且多余减1操作导致少统计一行/列
• 拼写错误：offest应为Offset
• Average参数重复嵌套Range：SrcRng本身就是Range对象，无需再用Range(SrcRng)包裹
• 变量未声明：Sht变量未提前定义，开启强制变量声明时会直接报错
• 循环边界判断逻辑错误，导致最后不足压缩比例的行/列处理逻辑异常

修正后完整代码 #

Public Sub ChngGraphRes(Sourcegraph As String, Destgraph As String, xRatio As Long, yRatio As Long)
    ' 声明变量
    Dim SrcSht As Worksheet, DestSht As Worksheet
    Dim SrcRng As Range, CurPos As Range, DestRng As Range
    Dim lstRow As Long, lstCol As Long
    Dim curH As Long, curW As Long
    Dim SrcAvg As Double
    
    ' 初始化工作表
    Set SrcSht = ThisWorkbook.Worksheets(Sourcegraph)
    Set DestSht = ThisWorkbook.Worksheets(Destgraph)
    DestSht.Cells.Clear
    
    ' 可靠获取源数据最大行、最大列，兼容空单元格场景
    With SrcSht
        lstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lstCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    
    ' 初始化指针位置
    Set CurPos = SrcSht.Range("A1")
    Set DestRng = DestSht.Range("A1")
    
    ' 遍历行维度
    Do While CurPos.Row <= lstRow
        ' 计算当前块的高度，不足yRatio则取剩余所有行
        curH = Application.Min(yRatio, lstRow - CurPos.Row + 1)
        
        ' 遍历列维度
        Do While CurPos.Column <= lstCol
            ' 计算当前块的宽度，不足xRatio则取剩余所有列
            curW = Application.Min(xRatio, lstCol - CurPos.Column + 1)
            
            ' 计算块均值，兼容空值/无有效数值场景
            Set SrcRng = CurPos.Resize(curH, curW)
            If Application.Count(SrcRng) > 0 Then
                SrcAvg = WorksheetFunction.Average(SrcRng)
            Else
                SrcAvg = 0 ' 无有效数值时默认写0，可按需修改
            End If
            DestRng.Value = SrcAvg
            
            ' 列指针右移
            Set CurPos = CurPos.Offset(0, xRatio)
            Set DestRng = DestRng.Offset(0, 1)
        Loop
        
        ' 行指针下移，列指针复位到第一列
        Set CurPos = SrcSht.Cells(CurPos.Row + yRatio, 1)
        Set DestRng = DestSht.Cells(DestRng.Row + 1, 1)
    Loop
End Sub

调用示例 #

比如需要将"源数据"表按x压缩比例3、y压缩比例2输出到"压缩后数据"表，调用代码如下：

Sub 测试调用()
    Call ChngGraphRes("源数据", "压缩后数据", 3, 2)
End Sub

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