Как вставить строки, заполненные данными, основанными на значении ячейки, и перенести строки на другой лист, помещенный под заголовком Speci c в Excel VBA.

Question

Я прошу прощения, если я не могу объяснить это полностью, VBA достаточно сложен для меня, чтобы понять!

У меня есть отдельная таблица для количественного определения количества описанных мной «контрольных целей» того же типа по «Счету доменов» в столбце J. В столбце J - функция COUNTIFS, которая подсчитывает все домены каждого числа, которое у меня есть. Например, у меня есть 4 домена 1, 7 доменов 2 и т. Д. c.

. Я хочу вставить сумму из столбца «Домен #» под соответствующим заголовком в столбце B. Лист2. Например, я хочу вставить 4 строки в «Домен 1», 7 строк в «Домен 2» и т. д.

Далее я хочу скопировать и вставить соответствующую цель управления, идентификатор компании и категорию контроля из листа 1 в Sheet2 под соответствующим заголовком. Например, все контрольные цели в домене 1 будут тянуть столбцы D, E и G с листа Sheet1 на лист Sheet2.

Пожалуйста, смотрите скриншоты для дальнейшего ознакомления и визуализируйте, что я пытаюсь достичь.

Лист1

Лист2

Вот код, который кто-то дал мне, но он не работает:

    Sub add_domain_rows()

Dim row_i As Long
Dim row_j As Long
Dim no_of_rows_to_get As Integer
Dim additional_rows As Integer
Dim rolling_start As Integer

row_i = 3
While ThisWorkbook.Sheets("Sheet2").Cells(row_i, "B").Value <> vbNullString

    'Check if there is a need to copy the data
    If Split(ThisWorkbook.Sheets("Sheet1").Cells(row_i, "A").Value, " ")(0) _
                                                            = "Domain" Then

        'Find how many rows need to be added
        row_j = 2
        rolling_start = 1
        While ThisWorkbook.Sheets("Sheet1").Cells(row_j, "I").Value _
                                                         <> vbNullString

            If ThisWorkbook.Sheets("Sheet1").Cells(row_j, "I").Value _
                     = Int(Split(ThisWorkbook.Sheets("Sheet2").Cells(row_i, _
                                             "B").Value, " ")(1)) Then

                no_of_rows_to_get = _ 
                       ThisWorkbook.Sheets("Sheet1").Cells(row_j, "J").Value
                GoTo Exit_While_Because_I_found_the_number:

            End If

            'get the number of relevant row from top of the list
            'to know where to copy data from
            rolling_start = rolling_start + _
                       ThisWorkbook.Sheets("Sheet1").Cells(row_j, "J").Value

            row_j = row_j + 1
        Wend

Exit_While_Because_I_found_the_number:

        'add the relevant number of blank rows
        For additional_rows = 1 To no_of_rows_to_get - 1

            ThisWorkbook.Sheets("Sheet1").Range("B" & (row_i + 1) & ":D" & _
                                           (row_i + 1)).Insert shift:=xlDown

        Next additional_rows

        'copy/paste the relevant range
        ThisWorkbook.Sheets("Sheet1").Range("D" & (rolling_start + 1) & _
                           ":E" & (rolling_start + no_of_rows_to_get)).Copy _
        (ThisWorkbook.Sheets("Sheet2").Range("B" & (row_i + 1)))
        ThisWorkbook.Sheets("Sheet1").Range("G" & (rolling_start + 1) & _
                           ":G" & (rolling_start + no_of_rows_to_get)).Copy _
        (ThisWorkbook.Sheets("Sheet2").Range("D" & (row_i + 1)))


    End If

    'Jump to the next row
    row_i = row_i + 1 + no_of_rows_to_get

Wend


End Sub

А вот код Я пытался использовать безрезультатно:

Sub TransferData() 'The sub routine name.

Application.ScreenUpdating = False  '---->Prevents screen flickering as the code executes.
Application.DisplayAlerts = False  '---->Prevents warning "pop-ups" from appearing.

         Range("B1", Range("B" & Rows.count).End(xlUp)).AutoFilter 1, "Domain 1"  'Filters Column B for "Domain 1"
         Range("A2", Range("D" & Rows.count).End(xlUp)).Copy Sheet2.Range("A" & Rows.count).End(xlUp)(2)  ' Copies row data from Columns A - N & transfers it _
to sheet2 into the next available row.
         Range("A2", Range("D" & Rows.count).End(xlUp)).Delete '---->Deletes the "used" data from sheet1. This also prevents duplicates in sheet2.
   [I1].AutoFilter  'Turns off the autofilter.

Application.CutCopyMode = False  '---->Prevents the "marching ants" from bordering the copied rows of data.
Application.DisplayAlerts = True   '---->Resets the default.
Application.ScreenUpdating = True  '---->Resets the default.
Sheet2.Select '---->Takes you directly to sheet2 (Closed Cases).

'Reference: https://www.excelguru.ca/forums/showthread.php?5671-Move-a-cell-row-to-another-worksheet-based-on-cell-value

End Sub  'Closes the sub routine.

Кроме того, я не уверен, как прикрепить файл здесь, поэтому, пожалуйста, посмотрите на эту ссылку для файла: https://www.excelforum.com/excel-programming-vba-macros/1309189-inserting-rows-with-data-from-one-worksheet-to-another-worksheet.html#post5293795