更好的方法来处理这个循环？有效，但看起来不优雅

Question

我有一个包含多个列的大型数据表，其中包含大部分结果一式三份的数据。每行包含来自每个主题的一个数据点的结果。大多数受试者有三个重复结果，但在某些情况下，只有一两个。工作表按主题 id 列排序（这是分配给 for 循环中使用的变量 rng 的命名范围）。

此循环测试“rng”范围内的“targetcell”（设置为包含主题 id 的工作表中的命名范围），找到任何主题的底行重复或三重值，然后生成在新插入的列中表示：

Set rng = Range("clonesptid")

col = ActiveCell.Column
ActiveCell.Offset(0, 1).EntireColumn.Insert
anchor = col - rng.Column
'MsgBox "cell to test is " & rng(1)

'debugging message box to check where the ptid range is
'MsgBox "Range for ptID is " & rng.Column & " and the active cell address is " & ActiveCell.Address & " and the activecell col is " & anchor


For Each cell In rng
'uncomment the line below to check the cell addresses
'    str = str & Cell.Address & " contains " & Cell.Value & "(above=" & Cell.Offset(-1, 0).Value & " below=" & Cell.Offset(1, 0).Value & vbNewLine
'    MsgBox "What is our test value?" & vbNewLine & cell.Value
    
    If IsEmpty(cell.Value) = True Then Exit For
    
    targetcell = cell.Value
    If cell.Row > 2 Then twoup = cell.Offset(-2, 0).Value
    If cell.Row > 1 Then oneup = cell.Offset(-1, 0).Value
    onedown = cell.Offset(1, 0).Value
    
    If IsEmpty(targetcell) = False Then
        If cell.Row = 1 Then
            'adds title with means to first header row
            Cells(1, col + 1).Value = Cells(1, col).Value & " mean"
        ElseIf cell.Row = 2 And targetcell <> oneup And targetcell <> onedown Then
        'test the first value, if unique mean = the value of the cell
            cell.Offset(0, anchor + 1).Value = cell.Offset(0, anchor).Value
        ElseIf targetcell <> oneup And targetcell <> onedown Then
        'for all the rest of the cells in the range, this condition tests for singlets
            cell.Offset(0, anchor + 1).Value = cell.Offset(0, anchor).Value
        ElseIf targetcell = oneup And targetcell <> twoup And targetcell <> onedown Then
        'test for two values
            cell.Offset(0, anchor + 1).Value = (cell.Offset(0, anchor).Value + cell.Offset(-1, anchor).Value) / 2
        ElseIf targetcell = oneup And targetcell = twoup And targetcell <> onedown Then
        'test for three values
            cell.Offset(0, anchor + 1).Value = (cell.Offset(0, anchor).Value + cell.Offset(-1, anchor).Value + cell.Offset(-2, anchor).Value) / 3
        Else
        'this is the first or second replicate of duplicates or triplicates, but not yet the bottom value
            cell.Offset(0, anchor + 1).Value = ""
        End If
    End If
    
Next

Answer 1

如果你有一个特定的操作，比如“向上和向下查找所有相同的值”，那么最好将它移到一个单独的方法中。

未经测试：

Sub tester()

    Dim rng As Range, cell As Range, dups As Range
    Dim lastDup As Range, col As Long, anchor As Long
    
    col = ActiveCell.Column
    Cells(1, col + 1).EntireColumn.Insert
    Cells(1, col + 1).Value = "Mean"
    
    Set rng = Range("clonesptid")
    anchor = col - rng.Column
    
    Set cell = rng.Cells(1)
    
    Do While Len(cell.Value) > 0
    
        Set dups = DupsRange(cell) 'get contiguous range with same value in column
        Set lastDup = dups.Cells(dups.Cells.Count)
        
        'calculate your average here
        lastDup.Offset(0, anchor + 1) = Application.Average(dups.Offset(0, anchor))
        
        Set cell = lastDup.Offset(1, 0) 'next set
    Loop

End Sub

'Given a cell, check up and down to find
'   the contiguous same-value range
Public Function DupsRange(c As Range) As Range
    Dim cStart As Range, cEnd As Range
    If Len(c.Value) = 0 Then Exit Function
    Set cStart = c
    Set cEnd = c
    Do While cStart.Row > 1
        If cStart.Offset(-1, 0).Value = c.Value Then _
            Set cStart = cStart.Offset(-1, 0) Else Exit Do
    Loop
    Do While cEnd.Row < Rows.Count
        If cEnd.Offset(1, 0).Value = c.Value Then _
            Set cEnd = cEnd.Offset(1, 0) Else Exit Do
    Loop
    Set DupsRange = c.Parent.Range(cStart, cEnd)
End Function