Прочитайте столбец A, вставьте строки на основе шаблона

Question

У меня есть данные в столбце A, которые выглядят следующим образом:

A
B
A
B
B
B
A
B
A
B

Некоторые точки:

1. Все A должны иметь хотя бы один B. Все A имеют B,все B имеют A. (это система учета - она ​​требует этого).
2. Любой A может иметь столько B, сколько необходимо.
3. После каждой комбинации AB [n] нам нуженC.
4. C должен быть вставленной строкой.Сортировка и фильтрация недопустимы (A, B и C - переменные, которые не заменяются алфавитными символами, как показано здесь).
5. Код не должен вставлять символ C выше первого A.

Ожидаемый результат:

A
B
C
A
B
B
B
C
A
B
C
A
B
C

Я уже посмотрел на это: Excel: вставлять новую строку каждые x строк с содержимым в соответствии с шаблоном , но шаблон основанна известной 27-строчной вставке.Это не имеет гарантированного шаблона в моей проблеме.

Answer 1

Использование Find и некоторых циклов do - это способ сделать это ...

Sub InsertC()
    Application.ScreenUpdating = False
    Dim Data As Range: Set Data = Worksheets("Sheet1").Range("A:A")
    Dim FirstCell As Range: Set FirstCell = Data.Find("A", LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
    Dim NextCell As Range, ACell As Range: Set ACell = FirstCell

    If Not ACell Is Nothing Then
        Do
            Set NextCell = ACell
            Do While NextCell.Offset(1, 0) = "B"
                Set NextCell = NextCell.Offset(1, 0)
            Loop
            If Not ACell = NextCell Then
                NextCell.Offset(1, 0).Insert Shift:=xlDown
                NextCell.Offset(1, 0) = "C"
            End If
            Set ACell = Data.Find("A", After:=NextCell, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByRows)
        Loop While ACell.Address <> FirstCell.Address
    End If
    Application.ScreenUpdating = True
End Sub

Answer 2

Будучи передовым мыслителем, я использовал несколько Do петель.

Sub InsertCs()
    Application.ScreenUpdating = False
    Const A As String = "A", B As String = "B", C As String = "C"
    Dim r As Long, r2 As Long
    With Worksheets("Sheet1")
        Do
            r = r + 1
            If .Cells(r, "A").Value = A And .Cells(r, "A").Offset(1).Value = B Then
                r2 = r + 1
                Do
                    r2 = r2 + 1
                Loop Until Cells(r2, "A").Value = "" Or Cells(r2, "A").Value = A Or Cells(r2, "A").Value = C

                If Not Cells(r2).Value = C Then
                    .Rows(r2).Insert xlDown
                    .Cells(r2, "A").Value = C
                End If
                 r = r2
            End If
        Loop Until Cells(r, "A").Value = ""
    End With
End Sub

Answer 3

_{1.У всех А должен быть хотя бы один B.}

Поскольку все А должны иметь хотя бы один B, ваша логика сводится к: Если текущая ячейка не B и ячейканепосредственно над B, затем вставьте строку и вставьте C.

Option Explicit

Sub Macro1()

    Dim i As Long
    Dim a As Variant, b As Variant, c As Variant

    a = "A"
    b = "B"
    c = "C"

    With Worksheets("sheet3")

        For i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 To 3 Step -1
            Select Case .Cells(i - 1, "A").Value2
                Case b
                    If .Cells(i, "A").Value2 <> b Then
                        .Rows(i).Insert
                        .Cells(i, "A") = c
                    End If
            End Select
        Next i
    End With

End Sub

Answer 4

Попробуйте этот простой код.Он будет зацикливаться с последней ячейки в столбце A, и если есть переменная varA, то varB вставит строку и добавит varC.Присвойте свои переменные при необходимости.

Dim varA As Variant, varB As Variant, varC As Variant

Dim Rng As Range, i As Long, lRow As Long

varA = "A"
varB = "B"
varC = "C"

lRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lRow To 2 Step -1
    If Cells(i, 1).Value = varB And Cells(i, 1).Offset(-1).Value = varA Then
        Cells(i, 1).Offset(1).EntireRow.Insert
        Cells(i, 1).Offset(1).Value = varC
    End If
Next i 

Answer 5

Попробуйте

Sub test()
    Dim vDB, vR()
    Dim A, B, C
    Dim i As Long, r As Long, n As Long

    A = "A"
    B = "B"
    C = "C"

    vDB = Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    n = 1
    ReDim Preserve vR(1 To n)
    vR(1) = vDB(1, 1)
    For i = 2 To r

        If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
            n = n + 1
            ReDim Preserve vR(1 To n)
            vR(n) = C
        End If
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = vDB(i, 1)
    Next i
    If vR(n) = B Then
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = C
    End If
    Range("c1").CurrentRegion.Clear
    Range("c1").Resize(n, 1) = WorksheetFunction.Transpose(vR)
End Sub

Если вы хотите несколько столбцов, то

Sub test2()
    Dim vDB, vR(), vS()
    Dim A, B, C
    Dim i As Long, r As Long, n As Long
    Dim col As Integer
    Dim Ws As Worksheet

    A = "A"
    B = "B"
    C = "C"

    vDB = Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    col = UBound(vDB, 2)

    n = 1
    ReDim Preserve vR(1 To col, 1 To n)
    For j = 1 To col
        vR(j, n) = vDB(1, j)
    Next j

    For i = 2 To r

        If vDB(i - 1, 1) = B And vDB(i, 1) = A Then
            n = n + 1
            ReDim Preserve vR(1 To col, 1 To n)
            vR(1, n) = C
        End If
        n = n + 1
        ReDim Preserve vR(1 To col, 1 To n)
        For j = 1 To col
            vR(j, n) = vDB(i, j)
        Next j
    Next i
    If vR(1, n) = B Then
        n = n + 1
        ReDim Preserve vR(1 To col, 1 To n)
        vR(1, n) = C
    End If
    Set Ws = Sheets.Add 'Sheets("Result")
    With Ws
        .Range("a1").CurrentRegion.Clear
        .Range("a1").Resize(n, col) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 6

Sub MultipleSearch()

    Dim rng As Range
    Dim cll As Range
    Dim lrow As Long

    lrow = Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Range("A1:A" & lrow)

    Cells(lrow + 1, 1) = "C"

     For i = rng.Cells.Count To 2 Step -1
        If rng.Item(i) = "A" Then
            Rows(i).Insert
            Cells(i, 1) = "C"
        End If
    Next

End Sub