Сценарий VBA копирует и вставляет данные из таблицы в отдельные листы

Question

Я ищу некоторую помощь с этим макросом.У меня есть таблица данных, которую я пытаюсь разбить на отдельные вкладки, чтобы сделать ее более удобной для чтения.Столбец A содержит идентификатор записи и ее заголовок в столбце C. Действия, связанные с этой записью, указаны в строках ниже A-XXXX.

Может кто-нибудь помочь мне написать макрос, который будет повторять столбец A, найтизапись «D - ****» затем скопирует связанные с ней значения на другую рабочую таблицу и затем перейдет вниз по строкам ниже, чтобы зафиксировать данные действия.Затем зациклите и создайте другой лист и сделайте то же самое снова.

Мне удалось найти способ найти текст и скопировать лист, но я не думаю, что делаю это очень эффективно.Спасибо за любую помощь, которую вы можете предложить.

Код

Sub RiskCapture ()

'Переменные Dim cell As Range Dim sht Как рабочий лист Dim риск Как String Dim я как Integer DimSrchRng в качестве диапазона Dim RiskRng в качестве диапазона Dim RiskAddress в виде строки

'Screenupdating off' Application.ScreenUpdating = False

'Найти листы риска ("Downside_Risk_with_related_Act"). Выберите Set SrchRng = Range ("A2): A5 ") Для каждой ячейки в SrchRng Если cell.Value <>" "Тогда risk = cell.Value RiskAddress = cell.Address

'Copy Risk tab and rename to Risk ID
    Worksheets("Risk Tab").Copy After:=Worksheets("Downside_Risk_with_related_Act")
    ActiveSheet.Name = risk

'Risk ID Copy
    Sheets("Downside_Risk_with_related_Act").Select
    Cells.Find(what:=risk).Activate
    ActiveCell.Copy
    Sheets(risk).Select
    Range("C7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'Risk Title
    Sheets("Downside_Risk_with_related_Act").Select
    ActiveCell.Offset(0, 2).Select
    ActiveCell.Copy
    Sheets(risk).Select
    Range("C3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'Date
    Sheets(risk).Select
    Range("L3:M3").Select
    ActiveCell.FormulaR1C1 = Now()
    Range("L4").Select

'Status (Merge)
    Sheets(risk).Select
    Range("L7:M7").Select
    Selection.UnMerge

    Sheets("Downside_Risk_with_related_Act").Select
    ActiveCell.Offset(0, 3).Select
    ActiveCell.Copy

    Sheets(risk).Select
    Range("L7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    Range("L7:M7").Select
    Application.CutCopyMode = False
    Selection.Merge

'Owner(Merge)
    Sheets(risk).Select
    Range("G7:H7").Select
    Selection.UnMerge

    Sheets("Downside_Risk_with_related_Act").Select
    ActiveCell.Offset(0, 1).Select
    ActiveCell.Copy

    Sheets(risk).Select
    Range("G7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    Range("G7:H7").Select
    Application.CutCopyMode = False
    Selection.Merge


'Cause(Merge)
    Sheets(risk).Select
    Range("C10:E10").Select
    Selection.UnMerge

    Sheets("Downside_Risk_with_related_Act").Select
    ActiveCell.Offset(0, -3).Select
    ActiveCell.Copy

    Sheets(risk).Select
    Range("C10").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    Range("C10:E10").Select
    Application.CutCopyMode = False
    Selection.Merge


    End If

Next

'Screenupdating back' Application.ScreenUpdating = True

End Sub

введите описание изображения здесь