Automatic Serial Number before Text in a Cell

[arijitirf]

Hi!
In Column D, data of Column F:O flows through Text Join skipping Blank cell. I want a formula that generates auto incremental serial number (1, 2, 3, 4 and so on).

Let's assume,

Data in Column
F as "Rameshwaram"
G as "Somenath"
H as "Kedarnath"
I as " "
J as "Baidyanath"
K as " "
L as " "
M as "Kashi Viswanath"
N as "Trimbakeshwar"
O as "Mahakaleshwar"

Then data in Column D will be
1. '"Rameshwaram"'
2. "Somenath"
3. "Kedarnath"
4. "Baidyanath"
5. "Kashi Viswanath"
6. "Trimbakeshwar"
7. "Mahakaleshwar"

Is there any way to do that. I have come across a excellent formula in this forum which can do the same for Row however, the same is not useful for me.

Thanks in advance

 

[arijitirf]

I only had 3 rows of data to test. Forgot to change back. Which line gave you the error? Maybe try this. Change the sheet name to your sheet name

Sub PopulateColumn()
    Dim ws As Worksheet
    Dim rng As Range
    Dim dataArr As Variant
    Dim outputArr() As String
    Dim i As Long, j As Long
    Dim ct As Long
 
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change sheet name as needed.
    Set rng = ws.Range("F1:O503")
 
    dataArr = rng.Value
 
    ReDim outputArr(1 To UBound(dataArr, 1))
 
    For i = 1 To UBound(dataArr, 1)
        ct = 0
        outputArr(i) = ""
        For j = 1 To UBound(dataArr, 2)
            If Not IsEmpty(dataArr(i, j)) Then
                ct = ct + 1
                outputArr(i) = outputArr(i) & ct & ". " & dataArr(i, j) & Chr(10)
            End If
        Next j
        outputArr(i) = Left(outputArr(i), Len(outputArr(i)) - 1)
    Next i
 
    ws.Range("D1").Resize(UBound(outputArr), 1).Value = Application.Transpose(outputArr)
 
    Application.ScreenUpdating = True
End Sub

outputArr(i) = Left(outputArr(i), Len(outputArr(i)) - 1)

Above lines getting Run-time Error

 

[Cubist]

hmmm..ok it works fine on my end. how about this?

Sub PopulateColumn()
    Dim ws As Worksheet
    Dim rng As Range
    Dim dataArr As Variant
    Dim outputArr() As String
    Dim i As Long, j As Long
    Dim ct As Long
  
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set rng = ws.Range("F1:O503")
  
    dataArr = rng.Value
  
    ReDim outputArr(1 To UBound(dataArr, 1))
  
    For i = 1 To UBound(dataArr, 1)
        ct = 0
        ReDim tempArr(1 To UBound(dataArr, 2))
        For j = 1 To UBound(dataArr, 2)
            If Not IsEmpty(dataArr(i, j)) Then
                ct = ct + 1
                tempArr(ct) = ct & ". " & dataArr(i, j)
            End If
        Next j
        outputArr(i) = Join(tempArr, vbLf)
    Next i
    ws.Range("D1").Resize(UBound(outputArr), 1).Value = Application.Transpose(outputArr)
    Application.ScreenUpdating = True
End Sub

 

[arijitirf]

Now it is working perfectly fine.

Once more help, if possible, the Range F3:O503 has formula, for that all the lines having formula are coming with only serial numbers even there is no data in Range F3:O503.

I apologize for not adding excel mini sheet as my organization has very strong privacy policy and feel very embarrassed to bother you. Thank you for your help.

 

[Joe4]

Once more help, if possible, the Range F3:O503 has formula, for that all the lines having formula are coming with only serial numbers even there is no data in Range F3:O503.

It is best to give us ALL these important details (size of range, what is in them, rules, etc) up front in your initial post, instead of piece-meal throughout the post so we are constantly having to change the reply. Sometimes, we may take an entirely different approach if we know all the details up front (and don't waste time with other solutions that might not work for you).

Editing my original code, this will do the entire range F3:O503, regardless of whether the values returned are from formulas or hard-coded values:

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

 

[arijitirf]

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

Wow!! Thanks a Lot!!!

I sincerely apologize for giving details in bits and pieces.

I am grateful to you both.

 

[Joe4]

You are welcome.
Glad we were able to help.