Autofill and Reverse Autofill

**Anshu** · 07-03-2020, 11:25 PM

I have a sheet in which I want to autofill 3 cells by 3 different values based on a cell value from a range.
And also, in reverse, I want to autofill the single cell with the value, if I filled the 3 cells manually.

Please see the attachement Autofill.xlsx. I have explained everything there, in the attachment, in detail.

Thank you!!

**DocAElstein** · 07-04-2020, 02:57 PM

Hi
( Probably the word “Autofill” is not so good for this, since it is a bit miss leading: In Excel Auto Fill has a specific meaning) .

The solution I am thinking of for you is quite easy, but needs a bit of typing in of a lot of text.
So I will do the solution to work on just the first 3 rows using the first 5 rows of data in the Reference Chart. See if you can modify the macro to work for all the rows and data. If you have difficulties, let me know, and then I can complete it all for you in a day or so.

It is also a bit easier to explain the solution for others in the forum if I use a smaller data set.

So my solution, which I will give in the next post will solve this problem, which is your problem shortened.

_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	B	C	D	E	F
2	S. No.	Alpha Code	Sex	Category	Area
3	1
4	2
5	3

Worksheet: Sheet1
Case1
If I paste or enter A in cell C3, then, automatically put the value…
BOY in cell D3, GEN in cell E3 and URBAN in cell F3, as per the REFERENCE CHART
Similarly,
If I paste or enter B in cell C3, then, automatically put the value…
BOY in cell D3, OBC in cell E3 and URBAN in cell F3
Similarly, as shown in REFERENCE CHART, the corresponding value should be filled in the corresponding cells automatically
Now, similarly, same condition is applied to cell C4, C5, ….. that is, If I paste or enter A in cell C4, then, automatically put the value…
BOY in cell D4, GEN in cell E4 and URBAN in cell F4

_____ Workbook: Autofill.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	R	S	T	U	V
1	REFERENCE CHART
2	S. No.	Alpha Code	Sex	Category	Area
3	1	A	BOY	GEN	URBAN
4	2	B	BOY	OBC	URBAN
5	3	C	BOY	SC	URBAN
6	4	D	BOY	ST	URBAN
7	5	E	GIRL	GEN	URBAN

Worksheet: Sheet1

Case2
If I paste or enter BOY in cell D3, GEN in cell E3 and URBAN in cell F3
then, automatically put the value A in cell C3
Similarly,
If I paste or enter BOY in cell D3, OBC in cell E3 and URBAN in cell F3
then, automatically put the value B in cell C3

**DocAElstein** · 07-04-2020, 02:58 PM

I think this macro does what you want. I have not checked it thoroughly. I leave it to you to check thoroughly that it does all what you want.
If you have difficulty modifying it for your full range, then let me know and I will do it for you in a few days.

Code:

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 procedute can only work on single cell entzries in column C
        If Len(Target.Value) <> 1 Then Exit Sub
        If InStr(1, ",A,B,C,D,E,", "," & Target.Value & ",", vbBinaryCompare) = 0 Then Exit Sub
        Dim PosS As Long: Let PosS = (InStr(1, ",A,B,C,D,E,", Target.Value, 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 = Me.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.Rows.Count <> 1 Then Exit Sub ' more than 1 row selected, but this procedure can only work on single row entries
    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

I tried a few values and got these sorts of results

_____ Workbook: Autofill.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	B	C	D	E	F	H
2	S. No.	Alpha Code	Sex	Category	Area
3	1	E	GIRL	GEN	URBAN	7
4	2	D	BOY	ST	URBAN
5	3	B	BOY	OBC	URBAN
6	4

Worksheet: Sheet1

Autofile.xlsm:
https://app.box.com/s/mt1c2xvdejjj6d3vjo6wkjyrdxrs98tm

**Anshu** · 07-11-2020, 11:17 PM

A lot of thanks for this help Sir!

I have 4 issues...

1. The Table should NOT be dependent on the References Chart, that is, if I delete the Reference Chart completely, still the code should work. (Actually, It does not work when I delete the Reference Chart).

2. If I delete the Alpha Code from a cell (for example C3), the corresponding range (D3:F3) should be empty/deleted automatically.

3. (Similar to point 2 but in reverse order) 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.

4. If I enter "a" instead of "A" in the Alpha Code, the code should still work. (Actually, it does not work with small letters, only work with caps lock on)

**DocAElstein** · 07-12-2020, 05:28 PM

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

Code:

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