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]

Your code does not clear the data in column D. So if it is populated previously, it will not erase that data. If that is what you want it to do, try adding to the last If so it clears D:

' 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

 

[kvsrinivasamurthy]

Try this change

If Len(str) > 0 Then
Cells(r, "D").Value = Left(str, Len(str) - 1) : str=""
End If

 

[arijitirf]

Try this change

If Len(str) > 0 Then
Cells(r, "D").Value = Left(str, Len(str) - 1) : str=""
End If

@NateSC
I tried with the changes you have mentioned, but after run the in worksheet selection change and after run the code it is falling under loop.

@kvsrinivasamurthy
Your code is also not working under Worksheet selection change sub.

 

[arijitirf]

@NateSC
Since the code it too long to excute, is there any other alternative to get result faster. Next R is taking too long to respond under worksheet selection change sub.

Thanks in advance.

 

[myall_blues]

Is there a reason you are running this code through the Worksheet_SelectionChange event? The solutions suggested will work fine if you add it as module level code.

 

[arijitirf]

Is there a reason you are running this code through the Worksheet_SelectionChange event? The solutions suggested will work fine if you add it as module level code.

I want to run this code in Worksheet_Selection Change because data in Column F to O keep changing in through some excel formula based on input made in another sheet.

 

[myall_blues]

If that's the case I think you need the Worksheet_Change event, which triggers whenever any cell in the worksheet is changed. The Worksheet_SelectionChange event triggers when a cell is selected.
In any event it can't be just a Sub - it needs to specifically be that event in the relevant sheet.

Following incorporates modification by @NateSC

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyRange 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
    Set MyRange = Range("F3:O503")
    If Not Intersect(Target, MyRange) Is Nothing Then
    
        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)
            Else
                Cells(r, "D").Value = ""
            End If
        Next r
        
        Application.ScreenUpdating = True
        
    End If
End Sub

 

[kvsrinivasamurthy]

Can you post a sample file in some website and give link here.
Also I think F to O there are formulas and the output varies when changes are made in other cells.

 

[arijitirf]

If that's the case I think you need the Worksheet_Change event, which triggers whenever any cell in the worksheet is changed. The Worksheet_SelectionChange event triggers when a cell is selected.
In any event it can't be just a Sub - it needs to specifically be that event in the relevant sheet.

Following incorporates modification by @NateSC

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyRange 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
    Set MyRange = Range("F3:O503")
    If Not Intersect(Target, MyRange) Is Nothing Then
  
        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)
            Else
                Cells(r, "D").Value = ""
            End If
        Next r
      
        Application.ScreenUpdating = True
      
    End If
End Sub

No changes. Same loop is delayed the process.