Как автоматически вставить скопированную строку после определенного значения в ячейку с помощью VBA

Question

У меня есть таблица, которая содержит набор пакетов, которые должны быть разбиты на их компоненты.Для этого я ищу инструкции VBA, которые будут копировать любую строку, содержащую тег «-edubnd» в конце ячейки «sku» (см., Например, таблицу ниже), дважды под собой.

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

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

В настоящее время я отфильтровываю набор данных, копирую его в другой документ Excel, затем выполняю:

Sub insertrows()
    Dim I As Long
    Dim xCount As Integer

LableNumber:
    xCount = 2
    For I = Range("A" & Rows.CountLarge).End(xlUp).Row To 1 Step -1
        Rows(I).Copy
        Rows(I).Resize(xCount).Insert
    Next
    Application.CutCopyMode = False
End Sub

Текущая таблица:

column1   |    column2    |  column3 |  column3
----------------------------------------------
  A       |      pear     |  blue    |  10
  A       |      apple    |  orange  |  50
  A       |      orange   |  yellow  |  30
  A       |      kiwi     |  yellow  |  20
  A       | orange-edubnd |  blue    |  100
  A       |      apple    |  green   |  10
  A       |  pear-edubnd  |  green   |  50
  A       |      mango    |  pink    |  60

Желаемая таблица

Примечание: скопированная строка после каждого отдельного столбца2 с тегом -edubnd

 column1   |    column2    |  column3 |  column3
----------------------------------------------
  A       |      pear     |  blue    |  10
  A       |      apple    |  orange  |  50
  A       |      orange   |  yellow  |  30
  A       |      kiwi     |  yellow  |  20
  A       | orange-edubnd |  blue    |  100
  A       | orange-edubnd |  blue    |  100
  A       | orange-edubnd |  blue    |  100
  A       |      apple    |  green   |  10
  A       |  pear-edubnd  |  green   |  50
  A       |  pear-edubnd  |  green   |  50
  A       |  pear-edubnd  |  green   |  50
  A       |      mango    |  pink    |  60

Answer 1

Рад попробовать этот код после внесения соответствующих изменений в его параметры.

Sub InsertDuplicates()

    Const TestClm As String = "B"               ' modify as appropriate
    Const SearchCrit As String = "edubnd"

    Dim R As Long

    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("InsRows")     ' change as appropriate
        For R = .Cells(.Rows.Count, TestClm).End(xlUp).Row To 2 Step -1
            If InStr(1, .Cells(R, TestClm).Value, SearchCrit, vbTextCompare) Then
                .Rows(R).EntireRow.Copy
                .Range(.Rows(R + 1), .Rows(R + 2)).Insert Shift:=xlDown
                Application.CutCopyMode = False
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

В меню GUI листа Excel это называется Вставить скопированные ячейки.

Option Explicit

Sub Macro1()

    Dim i As Long

    With Worksheets("sheet1")

        For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
            If Right(.Cells(i, "B").Value2, 7) = "-edubnd" Then
                .Cells(i, "A").Resize(1, 4).Copy
                .Cells(i, "A").Resize(2, 4).Insert Shift:=xlDown
                Application.CutCopyMode = False
            End If
        Next i

    End With '

End Sub