Auto Serial Number in a Cell

[arijitirf]

Hi!
I have been using a code below, that is working flawlessly. I want data in D to be updated if I remove data from Column F to O.

Suppose, there is data in F3, G3, J3, K3, N3 & O3 and after execute the code data will populate in D3. Now if I delete all the data from F3 and O3 and run the code then D3 will not populate anything since there is no data b/w Column F and O (in the below code, data in D3 is still showing after run the code though there is no data b/w Column F and O)

Sub PopulateColumn()

Dim fr as Long
Dim lr As Long
Dim r As Long
Dim c As Long
Dim ct As Long
Dim str As String

Application.ScreenUpdating = False

' Set first and last rows to loop through
fr = 3
lr = 503

' Loop through all rows
For r = fr To lr
' Reset counter and string variable
ct = 0
str = ""
' Loop through columns F (6) to O (15)
For c = 6 To 15
' Check to see if it is a non-blank value
If Cells(r, c).Value <> "" Then
' Add one to counter
ct = ct + 1
' Build on to string
str = str & ct & ". " & Cells(r, c).Value & Chr(10)
End If
Next c
' Put result in column D
If Len(str) > 0 Then
Cells(r, "D").Value = Left(str, Len(str) - 1)
End If
Next r

Application.ScreenUpdating = True

End Sub

Requesting help.

Thanks in advance

 

[NateSC]

An improvement would be to only run this for the changed row. Don't process all rows. try this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim fr As Long
Dim lr As Long
Dim r As Long
Dim c As Long
Dim ct As Long
Dim str As String

    r = Target.Row
    'Application.ScreenUpdating = False

    ' Reset counter and string variable
    ct = 0
    str = ""
 
    For c = 6 To 15
        ' Check to see if it is a non-blank value
        If Cells(r, c).Value <> "" Then
        ' Add one to counter
        ct = ct + 1
        ' Build on to string
        str = str & ct & ". " & Cells(r, c).Value & Chr(10)
        End If
    Next c
    ' Put result in column D
    If Len(str) > 0 Then
        Cells(r, "D").Value = Left(str, Len(str) - 1)
    Else
        Cells(r, "D").Value = ""
    End If

    'Application.ScreenUpdating = True

End Sub

 

[arijitirf]

An improvement would be to only run this for the changed row. Don't process all rows. try this:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim fr As Long
Dim lr As Long
Dim r As Long
Dim c As Long
Dim ct As Long
Dim str As String

    r = Target.Row
    'Application.ScreenUpdating = False

    ' Reset counter and string variable
    ct = 0
    str = ""
 
    For c = 6 To 15
        ' Check to see if it is a non-blank value
        If Cells(r, c).Value <> "" Then
        ' Add one to counter
        ct = ct + 1
        ' Build on to string
        str = str & ct & ". " & Cells(r, c).Value & Chr(10)
        End If
    Next c
    ' Put result in column D
    If Len(str) > 0 Then
        Cells(r, "D").Value = Left(str, Len(str) - 1)
    Else
        Cells(r, "D").Value = ""
    End If

    'Application.ScreenUpdating = True

End Sub

Excellent! Now it is working without any flaw. Thank you so much @NateSC and others who have taken interest in my topic and help me to find solutions.

 

[NateSC]

I think you could improve the speed further if needed by reading the values to an array and then performing the FOR loop on the array. I tried this and ran into a problem I couldn't solve quickly.

 

[arijitirf]

I think you could improve the speed further if needed by reading the values to an array and then performing the FOR loop on the array. I tried this and ran into a problem I couldn't solve quickly.

Ok. But since the code is running perfectly fine with the modified version of the code you provided, it is not required. I must appreciate your effort. Thanks a Ton @NateSC