Модификация кода VBA для выбора всего столбца, застрахованного только в одной ячейке

Question

Я нашел это на этом сайте, напиши это Даном Донохью

Sub BoldTags()
Dim X As Long, BoldOn As Boolean

BoldOn = False 'Default from start of cell is not to bold

For X = 1 To Len(ActiveCell.Text)
    If UCase(Mid(ActiveCell.Text, X, 3)) = "<B>" Then
        BoldOn = True
        ActiveCell.Characters(X, 3).Delete
    End If
    If UCase(Mid(ActiveCell.Text, X, 4)) = "</B>" Then



    BoldOn = False
        ActiveCell.Characters(X, 4).Delete
    End If
    ActiveCell.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub

Я ничего не знаю о кодировании, магии или об этом.

Answer 1

Это будет делать то, что вы хотите:

Sub BoldTags()
Dim rng As Range, X As Long, BoldOn As Boolean
' This works on a selection of cells, if you want it on a full column comment out the next line and uncomment the one below.
For Each rng In Selection
'For Each rng In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    BoldOn = False 'Default from start of cell is not to bold
    For X = 1 To Len(rng.Text)
        If UCase(Mid(rng.Text, X, 3)) = "<B>" Then
            BoldOn = True
            rng.Characters(X, 3).Delete
        End If
        If UCase(Mid(rng.Text, X, 4)) = "</B>" Then
            BoldOn = False
            rng.Characters(X, 4).Delete
        End If
        rng.Characters(X, 1).Font.Bold = BoldOn
    Next
Next
End Sub

Answer 2

Просто обведите ячейки в столбце activecell:

Sub BoldTags(r As Range)
    Dim X As Long, BoldOn As Boolean

    BoldOn = False 'Default from start of cell is not to bold

    For X = 1 To Len(r.Text)
        If UCase(Mid(r.Text, X, 3)) = "<B>" Then
            BoldOn = True
            r.Characters(X, 3).Delete
        End If
        If UCase(Mid(r.Text, X, 4)) = "</B>" Then
            BoldOn = False
            r.Characters(X, 4).Delete
        End If
        r.Characters(X, 1).Font.Bold = BoldOn
    Next
End Sub


Sub dural()
    Dim rng As Range, r As Range
    Set rng = Intersect(ActiveCell.EntireColumn, ActiveSheet.UsedRange)

    For Each r In rng
        Call BoldTags(r)
    Next r
End Sub

Примечание:

В Call нет необходимости
Убедитесь, что в списке нет пустых мест.