Excel добавляет и копирует значения строк в зависимости от количества совпадений

Question

Прежде всего, я совершенно новичок в VB и не очень разбираюсь в Excel.Во-вторых, я не уверен, что это правильный форум, чтобы задать этот вопрос, но я видел больше вопросов, касающихся моей проблемы.

У меня есть лист Excel с двумя столбцами с идентификаторами в нем.Примерно так:

Как видно на первом рисунке (в столбце 1), у вас есть 3 одинаковых идентификатора (синим цветом).Во втором столбце у вас один и тот же идентификатор (во втором ряду) только один раз.Есть ли способ создать какую-то функцию для дублирования второго столбца столько раз, сколько первый идентификатор имеет этот идентификатор?Таким образом, это выглядит как второе изображение:

РЕДАКТИРОВАТЬ: Идея функции / формулы заключается в том, что строки сдвигаются вниз.Не каждый идентификатор в столбце 1 имеет несколько одинаковых идентификаторов.Например, черная ячейка - это всего лишь одна ячейка. Следующий столбец A используется в качестве ссылки, и только «столбцы с b по F» следует «изменить».

Я пытался выполнить такие программы, как Kutools , но безуспешно.Поскольку на листе около 15 тыс. Строк, это займет много времени, чтобы сделать это вручную.

Я могу добавить пустую строку с VB, когда ячейка соответствует значению, но я не могу скопировать.

Я пробовал это, что, очевидно, не работает:

Sub BlankLine()

    Dim Rng As Range
    Dim WorkRng As Range
    On Error Resume Next
    xTitleId                   = "MyTest"
    Set WorkRng                = Application.Selection
    Set WorkRng                = Application.InputBox("Range", xTitleId, WorkRng.Address, Type: = 8)
    Set WorkRng                = WorkRng.Columns(1)
    xLastRow                   = WorkRng.Rows.Count
    Application.ScreenUpdating = False
    For xRowIndex = xLastRow To 1 Step - 1
        Set Rng                   = WorkRng.Range("A" & xRowIndex)
        If Rng.Value = "0" Then
            Rng.Offset(1, 0).EntireRow.Insert Shift: = xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Возможно ли это и кто-то готов дать указания?Заранее спасибо ...

Answer 1

Вот небольшой пример - не имея возможности увидеть больше ваших данных, невозможно узнать, куда идти дальше.

Sub Test()

Dim i As Long
Dim id As String

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    id = Cells(i, 1).Value
    If Cells(i + 1, 1).Value = id And Cells(i + 1, 2).Value <> id Then
        Range(Cells(i + 1, 2), Cells(i + 1, 6)).Insert Shift:=xlDown
        Range(Cells(i + 1, 2), Cells(i + 1, 6)).Value = Range(Cells(i, 2), Cells(i, 6)).Value
    End If
Next i

End Sub