Write to a cell once based on a value

[fuslela]

Hi All,
I have been searching high and low across the site for the answer to this question an unfortunately cannot find an answer.
I am trying to write to a cell based on a value, the cell must only be written to once and then locked.

For example, Cell A1 contains a formula and if the condition is true is populated with a 1. (this bit is working)
What I would like to do is populate B1 with 1 if A1 is 1. B1 must then be locked with the value 1. If A1 changes again, B1 must continue to be set to 1.

I am sure this is very simple but I can't find the answer anywhere...

Any ideas people of Mr Excel?

Thanks!

 

[Misca]

Try:

Sub FindOnes()

Dim Rng As Range
Dim Ones As Range

With Sheet1 'Edit to match your worksheet
    'Set the range where the 1s should be found:
    Set Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    
    On Error Resume Next    'Just in case the Ones could not be set
    
    'Find the ones, then finds the empty cells in column B:
    Set Ones = Find_Range(1, Rng, xlValues, xlWhole).Offset(, 1).SpecialCells(xlCellTypeBlanks)
    
    On Error GoTo 0 'Back to normal
    
    If Not Ones Is Nothing Then
        Ones.Value = 1
        Set Ones = Nothing  'Makes sure the set range is ereased from memory
    End If
    
End With

End Sub

Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    Dim FirstAddress As String
    
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False) 'Delete this term for XL2000 and earlier
        If Not c Is Nothing Then
            Set Find_Range = c
            FirstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
     
End Function

Cell locking / protection does nothing unless the worksheet is protected. Protected worksheets can be a bit tricky for macros. The easiest way to get around this without having to unprotect / protect the worksheet is to have the Column B empty and have macro write the values in it when needed. And to make sure the values only get entered once the Ones range is set to only use the blank cells in Column B.

 

[fuslela]

Thanks Misca,
I shall give it a try!

 

[fuslela]

Try:

Sub FindOnes()

Dim Rng As Range
Dim Ones As Range

With Sheet1 'Edit to match your worksheet
    'Set the range where the 1s should be found:
    Set Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
   
    On Error Resume Next    'Just in case the Ones could not be set
   
    'Find the ones, then finds the empty cells in column B:
    Set Ones = Find_Range(1, Rng, xlValues, xlWhole).Offset(, 1).SpecialCells(xlCellTypeBlanks)
   
    On Error GoTo 0 'Back to normal
   
    If Not Ones Is Nothing Then
        Ones.Value = 1
        Set Ones = Nothing  'Makes sure the set range is ereased from memory
    End If
   
End With

End Sub

Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
    
    Dim c As Range
    Dim FirstAddress As String
   
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
    
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False) 'Delete this term for XL2000 and earlier
        If Not c Is Nothing Then
            Set Find_Range = c
            FirstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
    
End Function

Cell locking / protection does nothing unless the worksheet is protected. Protected worksheets can be a bit tricky for macros. The easiest way to get around this without having to unprotect / protect the worksheet is to have the Column B empty and have macro write the values in it when needed. And to make sure the values only get entered once the Ones range is set to only use the blank cells in Column B.

This was a lot more difficult than I expected. You are right about the limitations! In the end, I decided to copy the row out based on a condition. I'll then use a vlookup to reference the cell I need on the copied sheet.