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

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

请注意，代码不完整，因为当我尝试运行它时，发生运行时错误 1004 ("Application-defined or object-defined error")，所以我停止了。

如有任何帮助和建议，我们将不胜感激。

Answer 1

编辑在 OP 在评论中提出进一步要求后

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

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

只需确保您的第一行是 "header" 行

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

Select range of cells with same value and elaborate

vba

excel

cells