excel - 如何更正代码以使其在 = "Metered"的单元格区域左侧的列中运行或插入公式

Question

我有一个工作表，其中 C 列有一个公式，如果 D 列 =“计量”，则该公式会查找值。
大部分是农场 worker 的用户可以覆盖它(或者可能使用“进行更正”按钮将其删除)。除非列 D = "Metered"，否则我不在乎列 C 是否被覆盖，因为数据验证可确保输入正常。除非负载是“计量的”，否则用户应该使用 Tab 键越过 C 列。作为故障保险，我在其他地方复制了“计量”查找公式，结果在 S 列中。我在下面的代码中没有收到任何错误，但它没有做任何事情——以前的版本会做一些事情，但不是正确的事物。显然，我无法自己解决这个问题，非常感谢您提供的任何帮助。我想每天在打开工作簿时运行一次故障保护(在笔记本电脑上运行并且速度很重要)。

Private Sub Workbook_Open()

    Application.OnTime TimeValue("02:57:00"), "SaveBeforeDailyRestart"
    Application.MoveAfterReturnDirection = xlToRight
    Call MeteredLookupRefreshFormula
    
End Sub

Sub MeteredLookupRefreshFormula()
  
    Sheet1.Unprotect Password:="Cami8"
  
    Dim bng As Range
    Set bng = Range("D8:D10009")
    
    For Each cell In bng
        If Value = "Metered" Then
            bng.Offset(0, -1).Select
            Selection.Value = "S & ActiveCell.Row)"
      Else
    End If
    
    Next
     
    Sheet1.Protect Password:="Cami8"

End Sub

Answer 1

循环通过单元格
快速修复(慢)

为了不依赖于偏移量，您还可以执行以下操作:

cell.EntireRow.Columns("C").Value = cell.EntireRow.Columns("S").Value

Sub MeteredLookupRefreshFormulaQuickFix()
  
    With Sheet1
        .Unprotect Password:="Cami8"
        With .Range("D8:D10009")
            Dim cell As Range
            For Each cell In .Cells
                If StrComp(CStr(cell.Value), "Metered", vbTextCompare) = 0 Then
                    cell.Offset(0, -1).Value = cell.EntireRow.Columns("S").Value
                End If
            Next cell
        End With
        .Protect Password:="Cami8"
    End With

End Sub

改进(快速)

如果您有许多包含计算为空字符串的公式的单元格 =""在列底部 D , 替换 xlFormulas与 xlValues让这些细胞不被处理并加快速度。

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Refreshes...
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:        RefColumn,GetRange.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub MeteredLookupRefreshFormula()
  
    Const cfcAddress As String = "D8"
    Const dCol As String = "C"
    Const sCol As String = "S"
    Const Criteria As String = "Metered"
    Const pw As String = "Cami8"
    
    Sheet1.Unprotect Password:=pw
    
    Dim crg As Range: Set crg = RefColumn(Sheet1.Range(cfcAddress))
    If crg Is Nothing Then Exit Sub ' no data

    Dim cData As Variant: cData = GetRange(crg)
    Dim drg As Range: Set drg = crg.EntireRow.Columns(dCol)
    Dim dData As Variant: dData = GetRange(drg)
    Dim sData As Variant: sData = GetRange(crg.EntireRow.Columns(sCol))
    
    Dim r As Long
    For r = 1 To UBound(cData, 1)
        If StrComp(CStr(cData(r, 1)), Criteria, vbTextCompare) = 0 Then
            dData(r, 1) = sData(r, 1)
        End If
    Next r
    
    drg.Value = dData

    Sheet1.Protect Password:=pw

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range ('crg') whose first
'               cell is defined by the first cell of the range ('FirstCell')
'               and whose last cell is the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function