Question

我在A列中有如下数据：

A
B
A
B
B
B
A
B
A
B

一些要点：

所有A都必须至少有一个B。所有A都必须有B，所有B都必须有A。（这是一个会计系统-要求这样做）。
任何A都可以根据需要拥有多个B。
在每个A.B [n]组合之后，我们需要一个C。
C必须是插入的行。不允许进行排序和过滤（A，B和C是不能用字母字符代替的变量，如此处所示）。
该代码不应在第一个A上方插入C。

预期输出：

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

我已经看过这个：Excel: Insert new line every x rows with content according to a pattern 但是该模式基于已知的27行插入。这对我的问题没有保证。

Answer 1

尝试

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 2

_{1。所有A必须至少有一个B。}

由于所有A都必须至少具有一个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 3

作为有远见的思想家，我使用了多个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 4

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

Answer 5

尝试以下简单代码。它将从列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 6

使用查找和一些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

读取A列，根据模式插入行

6 个答案: