Autofill and Reverse Autofill

[DocAElstein]

Hi
_ 4.
This is easy, simply convert the Target.Value to UCase(Target.Value) , and use that converted character in place of Target.Value
( If the Target.Value is already uppercase, then UCase(Target.Value) will not error - Target.Value will just stay as it is )


_ 2. And 3.
This is not difficult, but need s some juggling around with code lines
Two similar code sections are needed

_1. This is a bit more difficult. It is rather unusual not to have a range of the required LookUp information somewhere
This information must come from somewhere.
The most simple solution would be to have that range somewhere
For now , I have put the information on a second worksheet. And made a minor change to the macro to reference that worksheet
If this is not acceptable, then I can put the information somewhere else, such as in the macro itself.

---

So here is my next solution for you.
Once again for now, for clarity and simplicity, I have limited it just to a few rows

Private Sub Worksheet_Change(ByVal Target As Range)
 On Error GoTo Bed
    If Application.Intersect(Target, Me.Range("C3:F5")) Is Nothing Then Exit Sub ' No overlap with the entry range, so exit sub
' Case1
    If Not Application.Intersect(Target, Me.Range("C3:C5")) Is Nothing Then ' Column C entry
    If IsArray(Target.Value) Then Exit Sub ' more than one cell selected, but this procedure can only work on single cell entries in column C
        If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
         Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
         Let Target.Offset(0, 1).Resize(1, 3).Value = ""  '   If I delete the Alpha Code from a cell (for example C3), the corresponding range (D3:F3) should be empty/deleted automatically.
         Let Application.EnableEvents = True
        ElseIf Len(Target.Value) <> 1 Then Exit Sub ' we have an entry , but it is invalid
        Else
        End If
    Dim UcsTgtVl As String: Let UcsTgtVl = UCase(Target.Value)
        If InStr(1, ",A,B,C,D,E,", "," & UcsTgtVl & ",", vbBinaryCompare) = 0 Then Exit Sub
        Dim PosS As Long: Let PosS = (InStr(1, ",A,B,C,D,E,", UcsTgtVl, vbBinaryCompare) / 2) + 2 ' Row number in  REFERENCE CHART  for the corrsponding   Sex Category Area values
         Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
         Let Target.Offset(0, 1).Resize(1, 3).Value = ThisWorkbook.Worksheets("REFERENCE CHART").Range("T" & PosS & ":V" & PosS & "").Value
         Let Application.EnableEvents = True
' Case2
    ElseIf Not Application.Intersect(Target, Me.Range("D3:F5")) Is Nothing Then ' Entry in column D E or F
        If Target.Columns.Count = 1 Then
            If Target.Value = "" Then 'This would be a cleared cell ( deleted value )
             Let Application.EnableEvents = False ' This is to prevent the worksheet change in the next code line setting off this procedure again
             Let Me.Range("C" & Target.Row & "").Value = ""  '  If I delete any one cell value from the range (for example D3:F3), the corresponding Alpha Code (C3) should be deleted automatically. It means, the Alpha Code should be appear only if all the three cells in the corresponding range (for example D3:F3) are filled. Otherwise, the Alpha Code should be disappear/deleted.
             Let Application.EnableEvents = True
             Exit Sub
            Else
            End If
        ElseIf Target.Rows.Count <> 1 Then Exit Sub ' more than 1 row selected, but this procedure can only work on single row entries
        Else
        End If
    Dim arrSCA() As Variant: Let arrSCA() = Array("BOYGENURBAN", "BOYOBCURBAN", "BOYSCURBAN", "BOYSTURBAN", "GIRLGENURBAN")
    Dim TrgtRw As Long: Let TrgtRw = Target.Row
    Dim DEF As String: Let DEF = Me.Range("D" & TrgtRw).Value & Me.Range("E" & TrgtRw).Value & Me.Range("F" & TrgtRw).Value
    Dim Mtchres As Variant
     Let Mtchres = Application.Match(DEF, arrSCA, 0)
        If IsError(Mtchres) Then Exit Sub ' no matching set of entries in columns D E and F
    Dim PosS2 As Long: Let PosS2 = Mtchres + 2 ' Row number in  REFERENCE CHART  for the corresponding  Alpha Code
     Let Application.EnableEvents = False
     Let Me.Range("C" & TrgtRw & "").Value = Me.Range("S" & PosS2 & "").Value
     Let Application.EnableEvents = True
    Else
    End If
    
Bed: ' just incase anything goes wrong, it is a good idea to make sure that things are turned back to normal
 Let Application.EnableEvents = True
End Sub

Alan

---

Share ‘Autofill.xlsm’ : https://app.box.com/s/mt1c2xvdejjj6d3vjo6wkjyrdxrs98tm
( Macro copy : https://excelfox.com/forum/showthrea...ll=1#post14573 )