Add bullets to named range column

[Sumeluar]

Good day! - I need help on modifying the code below to do the following:

On a named range from columns C to J, I would like to add a bullet only to any text entered on Column D6 and down, if any cells on column D already containing a bullet has to be ignored so not to end up with multiple bullets. The below code came from a google search, it works but the range (Column D) needs to be selected manually and any cells already containing a bullet and the code is reapplied end up with an additional one.

Sub Add_Bullets()
Dim cell As Range
Dim vntLines As Variant
Dim lngIndex As Long
Dim strTemp As String
Sheets("EventsList").Select
For Each cell In Selection.Cells
strTemp = ""
vntLines = Split(cell.Value, vbLf)
For lngIndex = LBound(vntLines) To UBound(vntLines)
If Len(Trim(vntLines(lngIndex))) > 0 Then
strTemp = strTemp & Chr(149) & " " & vntLines(lngIndex) & vbLf
Else
strTemp = strTemp & vbLf
End If
Next
cell.Value = Left(strTemp, Len(strTemp) - 1)
Next cell
End Sub

I appreciate any new suggestions or improvements to the above code.

Best Regards!

 

[footoo]

Try this :

Sub Add_Bullets()
Dim cell As Range
Dim vntLines As Variant
Dim lngIndex As Long
Dim strTemp As String
Sheets("EventsList").Select
Dim rng As Range
Set rng = Range([D6], Cells(Rows.Count, "D").End(3))
For Each cell In rng
    strTemp = ""
    vntLines = Split(cell.Value, vbLf)
    For lngIndex = LBound(vntLines) To UBound(vntLines)
        If Len(Trim(vntLines(lngIndex))) > 0 And Left(Trim(vntLines(lngIndex)), 1) <> Chr(149) Then
            strTemp = strTemp & Chr(149) & " " & vntLines(lngIndex) & vbLf
        Else
            strTemp = strTemp & vntLines(lngIndex) & vbLf
        End If
    Next
    cell.Value = Left(strTemp, Len(strTemp) - 1)
Next cell
End Sub

 

[Sumeluar]

Try this :

Sub Add_Bullets()
Dim cell As Range
Dim vntLines As Variant
Dim lngIndex As Long
Dim strTemp As String
Sheets("EventsList").Select
Dim rng As Range
Set rng = Range([D6], Cells(Rows.Count, "D").End(3))
For Each cell In rng
    strTemp = ""
    vntLines = Split(cell.Value, vbLf)
    For lngIndex = LBound(vntLines) To UBound(vntLines)
        If Len(Trim(vntLines(lngIndex))) > 0 And Left(Trim(vntLines(lngIndex)), 1) <> Chr(149) Then
            strTemp = strTemp & Chr(149) & " " & vntLines(lngIndex) & vbLf
        Else
            strTemp = strTemp & vntLines(lngIndex) & vbLf
        End If
    Next
    cell.Value = Left(strTemp, Len(strTemp) - 1)
Next cell
End Sub

Footoo, thanks for the updated code, it works although having over a thousand cells it does take a while to go through the whole thing.

Regards!

 

[Joe4]

See if adding these two lines at the top and bottom of your code help speed it up:

Sub Add_Bullets()

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

Dim cell As Range
Dim vntLines As Variant
Dim lngIndex As Long
Dim strTemp As String
Sheets("EventsList").Select
Dim rng As Range
Set rng = Range([D6], Cells(Rows.Count, "D").End(3))
For Each cell In rng
    strTemp = ""
    vntLines = Split(cell.Value, vbLf)
    For lngIndex = LBound(vntLines) To UBound(vntLines)
        If Len(Trim(vntLines(lngIndex))) > 0 And Left(Trim(vntLines(lngIndex)), 1) <> Chr(149) Then
            strTemp = strTemp & Chr(149) & " " & vntLines(lngIndex) & vbLf
        Else
            strTemp = strTemp & vntLines(lngIndex) & vbLf
        End If
    Next
    cell.Value = Left(strTemp, Len(strTemp) - 1)
Next cell

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[Sumeluar]

See if adding these two lines at the top and bottom of your code help speed it up:

Sub Add_Bullets()

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

Dim cell As Range
Dim vntLines As Variant
Dim lngIndex As Long
Dim strTemp As String
Sheets("EventsList").Select
Dim rng As Range
Set rng = Range([D6], Cells(Rows.Count, "D").End(3))
For Each cell In rng
    strTemp = ""
    vntLines = Split(cell.Value, vbLf)
    For lngIndex = LBound(vntLines) To UBound(vntLines)
        If Len(Trim(vntLines(lngIndex))) > 0 And Left(Trim(vntLines(lngIndex)), 1) <> Chr(149) Then
            strTemp = strTemp & Chr(149) & " " & vntLines(lngIndex) & vbLf
        Else
            strTemp = strTemp & vntLines(lngIndex) & vbLf
        End If
    Next
    cell.Value = Left(strTemp, Len(strTemp) - 1)
Next cell

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Joe4 - That works flawless, thank you.

Big thanks to footoo as well.

Appreciate the quick and precise replies.

Best regards!

 

[Joe4]

Sumulear,

All I did was add these two lines at the top of the code:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

and then these two lines at the bottom:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

It doesn't change how the code runs, it just should speed it up by delaying the calculations and screen updates (you mentioned the code took a while to run).
Does it help it run any faster?

 

[Sumeluar]

Sumulear,

All I did was add these two lines at the top of the code:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

and then these two lines at the bottom:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

It doesn't change how the code runs, it just should speed it up by delaying the calculations and screen updates (you mentioned the code took a while to run).
Does it help it run any faster?

Joe4 - Both codes do the same thing but the first one literally would scroll down quite slowly. With the lines you added at the top and at the bottom it does run faster, I am fully satisfied how it runs.

 

[Joe4]

Joe4 - Both codes do the same thing but the first one literally would scroll down quite slowly. With the lines you added at the top and at the bottom it does run faster, I am fully satisfied how it runs.

Yes, that was exactly my intention. I did not change any of the body of the code. I simply added some lines to the top of the existing code that suppressing screen updates and calculations until the very end. This is a trick you can do on almost any VBA code that often helps speed it up.