如何更正代码，以便在范围的左边列中运行或插入=“计量”的单元格的公式

Question

我有一个工作表，其中C列有一个公式，如果D列=“计量”，它将查找值。用户大多是农场工人，他们有能力覆盖它(或者可能使用Make更正按钮删除它)。除非D列=“计量”，否则我不在乎C列是否被覆盖，因为数据验证确保条目没有问题。除非负载是“计量”的，否则用户应该选择通过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("S").Value cell.EntireRow.Columns("C").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

Answer 2

似乎您的FOR循环的内容都搞砸了。这是未经检验的但是改变这个..。

For Each cell In bng
    If Value = "Metered" Then
        bng.Offset(0, -1).Select
        Selection.Value = "S & ActiveCell.Row)"
  Else
End If

Next

..。为了这个..。

For Each cell In bng
    If cell.Value = "Metered" Then
        cell.Offset(0, -1).Value = cell.Worksheet.Range("S" & cell.Row).Value
    End If
Next

..。应该会有帮助的。