Вставить новую строку на основе логики с несколькими ячейками

Question

Я довольно новичок в VBA, и я искал как можно лучше, но до сих пор не могу найти ответ. Мне нужно написать макрос, который будет вставлять новую строку на основе нескольких условий. Ряды должны быть в группах не более 5 и разделены носителем. Но если контейнер повторяется, он считается за 1 строку.

Текущий:

Container   Carrier
ABC56   Carrier 1
XOS752  Carrier 1
IOW45   Carrier 1
WOFJ74  Carrier 1
NMC85   Carrier 1
DDJD7   Carrier 1
DFF789  Carrier 1
DFF789  Carrier 1
CSGS    Carrier 1
GSW132  Carrier 1
WYWI78  Carrier 1
WTS758  Carrier 1
MNV74   Carrier2
ADS78   Carrier2
CTDS45  Carrier2
CTDS45  Carrier2
LHKGL78 Carrier2
XJSS772 Carrier2
XJSHS7  Carrier2
OIJS7   Carrier2

Желаемая:

ABC56   Carrier 1
XOS752  Carrier 1
IOW45   Carrier 1
WOFJ74  Carrier 1
NMC85   Carrier 1

DDJD7   Carrier 1
DFF789  Carrier 1
DFF789  Carrier 1
CSGS    Carrier 1
GSW132  Carrier 1
WYWI78  Carrier 1

WTS758  Carrier 1

MNV74   Carrier2
ADS78   Carrier2
CTDS45  Carrier2
CTDS45  Carrier2
LHKGL78 Carrier2
XJSS772 Carrier2

XJSHS7  Carrier2
OIJS7   Carrier2

Я возьму любое направление у вас есть! У меня есть эти два кода отдельно. Один отделяется от носителя и один разделяется на 5 строк. Тем не менее, он не имеет всей встроенной логики.

Разделить на группы по 5 человек:

Option Explicit
    Sub InsertIT()
    Dim x As Integer
    x = 1 'Start Row
    Do
    Range("A" & x, "B" & x).Insert
    x = x + 6
    Loop
    End Sub

Разделить по перевозчику:

 Sub InsertRowAtChangeInValue()
       For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 2 Step -1
          If Cells(lRow, "B") <> Cells(lRow - 1, "B") Then Rows(lRow).EntireRow.Insert
       Next lRow
    End Sub

Answer 1

Я скопировал ваши образцы данных, и этот макрос дает мне вывод, который вы ищете.

Я использовал while цикл вместо for цикл, потому что VBA записывает значение для конца for цикл, когда он запускается, и количество строк, необходимое для обработки изменений при вставке строк.

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

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

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

Если у вас есть вопросы, пожалуйста, прокомментируйте!

Sub RowInsert()

'Designate your data columns
ContainerCol = "A"
CarrierCol = "B"

'Designate where your data starts
FirstDataRow = 2

'Find last row to process
LastRow = Range(ContainerCol & Rows.Count).End(xlUp).Row

'Initialize variable for row counter
RowCount = 0

'Initialize while loop variable
i = FirstDataRow

'Loop while ContainerCol is populated
While Not IsEmpty(Cells(i, ContainerCol))

    'Check if container and carrier are repeated from previous row. Increment counter if no repetition
    If Cells(i, CarrierCol) <> Cells(i - 1, CarrierCol) Or Cells(i, ContainerCol) <> Cells(i - 1, ContainerCol) Then
        RowCount = RowCount + 1
    End If

    'Check if carrier changes on next row
    changeflag = 0 'Variable to indicate if carrier change detected, flag reset
    If Cells(i, CarrierCol) <> Cells(i + 1, CarrierCol) Then
        changeflag = 1
    End If

    'Insert row if carrier changing or 5 rows complete
    If RowCount >= 5 Or changeflag = 1 Then
        Rows(i + 1).EntireRow.Insert
        i = i + 1 'Increment so that the loop picks up at the right spot on the next iteration
        RowCount = 0 'Reset row counter
    End If

    'Increment loop counter
    i = i + 1

Wend

MsgBox ("Separated rows until blank was found at row " & i - 1 & ".")

End Sub

Answer 2

Вы можете избежать циклов, использующих вспомогательный столбец (столбец C, в моем следующем примере):

Sub InsertRows()
    With Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 4)
        With .Offset(1).Resize(.Rows.Count - 1)
            .FormulaR1C1 = "=IF(RC2<>R[-1]C2,1,"""")"
            .Value = .Value
            .SpecialCells(xlCellTypeConstants).EntireRow.Insert
        End With
        .FormulaR1C1 = "=IF(RC2="""",0,IF(RC1<>R[-1]C1,IF(R[-1]C=5,1,R[-1]C+1), R[-1]C))"
        .Value = .Value
        .Replace what:=5, replacement:=""
        .Resize(.Rows.Count - 1).SpecialCells(xlCellTypeBlanks).Offset(1).EntireRow.Insert
        .ClearContents
    End With
End Sub

и вы можете изменить вспомогательный столбец, просто изменив .Offset(, 2) к другому .Offset(, n)