Запуск одного макроса на несколько ячеек

Question

Я написал макрос, который вставляет несколько строк, а затем скрывает текст, присутствующий в одной ячейке, которые разделены разделителями от текстов до столбцов, а затем переносит их и копируется как строки, вставляющие специальные, которые были вставлен первым. Я могу запустить макрос только для одной ячейки, чтобы получить результат. но теперь я хочу запустить макрос на других 50 ячейках. как мне это сделать ??

Мой код ниже

Sub Newsroom() 
' 
' Macro 
' By Ganesh 
' 
' Keyboard Shortcut: Ctrl+Shift+G 
' 
    Selection.TextToColumns Destination:=ActiveCell, DataType:=xlDelimited, _ 
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _ 
     Semicolon:=True, Comma:=True, Space:=True, Other:=True, FieldInfo:= _ 
     Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7 _ 
     , 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array _ 
     (14, 1)), TrailingMinusNumbers:=True 
    ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    Selection.Insert Shift:=xlDown 
    ActiveCell.Offset(-1, 3).Range("A1").Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Selection.Copy 
    ActiveCell.Offset(1, -1).Range("A1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveCell.Offset(-1, 1).Range("A1").Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Application.CutCopyMode = False 
    Selection.ClearContents 
    ActiveCell.Offset(21, -1).Range("A1").Select 
    ActiveCell.FormulaR1C1 = "ALLNEWSPLUS" 
    With ActiveCell.Characters(Start:=1, Length:=11).Font 
     .Name = "Calibri" 
     .FontStyle = "Regular" 
     .Size = 10 
     .Strikethrough = False 
     .Superscript = False 
     .Subscript = False 
     .OutlineFont = False 
     .Shadow = False 
     .Underline = xlUnderlineStyleNone 
     .Color = -16777216 
     .TintAndShade = 0 
     .ThemeFont = xlThemeFontNone 
    End With 
    ActiveCell.Offset(-21, -2).Range("A1:B1").Select 
    Selection.AutoFill Destination:=ActiveCell.Range("A1:B22"), Type:= _ 
     xlFillDefault 
    ActiveCell.Range("A1:B22").Select 
End Sub 

Answer 1

без переписывания весь ваш код (вы должны избавиться от Selection и ActiveCell ссылок в пользу более объектно-ориентированного программирования), необходимо реализовать Loop.

Предполагая, что вы сначала выбрать диапазон ячеек (1 колонка), над которым вы хотите работать:

Sub foo() 
    Dim rng as Range 
    Dim r as Long 
    Set rng = Range(Selection.Address) 

    For r = rng.Cells.Count to 1 Step -1 
     rng.Cells(r).Select 

     ''''''''''''''''''''''''''''''''''' 
     ''''''''''''''''''''''''''''''''''' 
     ' ALL OF YOUR CODE BELONGS HERE 
     ' 
     ' 
     ' 
     ''''''''''''''''''''''''''''''''''' 
     ''''''''''''''''''''''''''''''''''' 

    Next 
End Sub