How to correct code so that it runs or inserts formula in column to left of Range for cells that = &-CodePudding

I have a worksheet where column C has a formula that looks up value if column D = "Metered". Users, who are mostly farm workers, have the ability to overwrite it (or possibly delete it using the Make Correction button). Unless column D = "Metered", I don't care if column C is overwritten because data validation makes sure entry is OK. Users are supposed to Tab past column C unless load is "Metered". As a failsafe, I duplicated the "Metered" lookup formula elsewhere and the results are in column S. I don't get any errors on code below, but it doesn't do anything -- previous versions would do things but not the right things. Clearly, I cannot solve this on my own and very much appreciate any help you can provide. I want to run the failsafe once a day when the workbook is opened (running on laptops and speed is important).

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

CodePudding user response：

Loop Through Cells

A Quick Fix (Slow)

To not be dependent on the offset you could additionally do:

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

An Improvement (Fast)

If you have many cells containing formulas evaluating to an empty string ="" at the bottom of column D, replace xlFormulas with xlValues for these cells not to be processed and speed up even more.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

CodePudding user response：

It appears as though the contents of your FOR loop is all screwed up. This is untested but change this ...

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

Next

... to this ...

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

... and it should help.