Question

我是VBA的新手，我正在尝试从实验中详细说明一些数据。

简而言之，我有2列，A和B. 在列A中，数字0和2重复多次，例如“0 0 0 0 2 2 2 2 0 0 0 0 0 2 2 2 0 0 0”。重复次数不是恒定的。我的最终目标是对B列中的数字的平均值进行对应于A列中连续的0或2的范围。换句话说，我的目的是有一个自动程序，从A列的第一个数据开始，定义一个具有相同值的细胞范围，并且右边的相应细胞的平均值。然后继续下一个范围。

这是我的代码：

Sub do_mean()

Dim myrange As Range
Dim first_cell As Range
Dim last_cell As Range
Dim mean_cell As Range
Dim n As Long
Dim j As Integer

Set first_cell = Cells(1, 1)

Do While Cells(j, 1).Value <> ""

If first_cell.Value = 0 Then
    For i = 0 To 10
    If first_cell.Offset(i, 0).Value = 2 Then
        Set last_cell = first_cell.Offset(i - 1, 0)
        n = i
        Exit For
        End If
    Next i
Set myrange = Range(first_cell, last_cell).Resize(1)
Set mean_cell = first.cell.Offset(3)
    mean_cell.Select
    ActiveCell.FormulaR1C1 = "=average(myrange)"
End If
 Set first_cell = last_cell.Offset(, 1)

 j = j + 1
Loop

End Sub

请注意代码不完整，因为当我尝试运行它时，会发生RunTime错误1004（“应用程序定义或对象定义错误”），所以我停止了。

任何帮助和建议将不胜感激，谢谢。

Answer 1

OP在评论中提出进一步请求后

已编辑

您可以使用AutoFilter()方法和Areas()对象的Range属性：

Option Explicit

Sub main()
    With Range("A1", cells(Rows.Count, 1).End(xlUp)) '<--| reference column A cells from row 1 (header) down to last not empty one
        GetMean .cells, 0
        GetMean .cells, 2
    End With
End Sub

Sub GetMean(rng As Range, val As Long)
    Dim area As Range

    With rng '<--| reference passed range
        .AutoFilter Field:=1, Criteria1:=val '<--| filter cells with passed value
        If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then '<--| if any filtered cells other than header
            For Each area In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).areas '<--| loop through each 'Area' i.e. each range of contiguous filtered cells
                area.cells(1).Offset(, 2) = WorksheetFunction.Average(area.Offset(, 1)) '<--| write the mean of cells in the next column of current 'area' two columns to the right of first 'area' cell
            Next
        End If
        .Parent.AutoFilterMode = False

        Application.DisplayAlerts = False '<--| prevent Excel UI to ask you about overwriting cells
        .Resize(.Rows.Count - 1).Offset(1, 2).SpecialCells(xlCellTypeBlanks).Delete xlUp '<--| select referenced range offset two columns to the right blank cells and delete them 
        Application.DisplayAlerts = True '<--| restore default Excel alert displaying
    End With
End Sub

请确保您的第一行是“标题”

选择具有相同值的单元格范围并详细说明

1 个答案: