Копирование данных над пустой ячейкой в ​​последнюю пустую ячейку до встречи со следующей ячейкой содержит

Question

Может ли кто-нибудь помочь мне, если это возможно сделать?

Логика такова: если ColA = 1 и ColC> = 1, то следует скопировать всю строку и вставить новую строку ниже последней пустой ячейки, прежде чем встречать следующую ячейку, содержащую 1, затем станет 0.

Сырье:

Окончательный результат должен быть:

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

Dim asd As Integer

Dim LastRow As Long

LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 

For zxc = 2 To C 

If Cells(zxc, "A").Value = 1 And Cells(zxc, "C").Value >= 1 Then

asd = asd + 1

End If

Next zxc

Dim AddCountRow As Long

AddCountRow = LastRow + asd

For i = 2 To AddCountRow

Dim A As Long

A = Worksheets("Sheet1").Cells(i, "A").Value 

Dim B As Long

B = Worksheets("Sheet1"). Cells(i + 1, "D"). Value 

If A >= 1 And B >= 1 Then

Cells(i + 1, "A").EntireRow.Insert

i = i + 1

End If

Next i

End Sub

Спасибо большое, ребята!

Answer 1

Это другой подход. Учитывая, возможно, у вас есть данные ниже и Lastrow не может быть надежным.

Найдите <<< Настройте это >>>, где я установил первую ячейку, где у вас есть заголовок.

Этот код охватывает данные в образце изображения:

Sub CopyInsertRows()

    Dim colAValue As String
    Dim colBValue As String
    Dim colCValue As String
    Dim colDValue As String

    Dim initialCell As String

    Dim rowCounter As Long

    ' <<< Customize this >>>
    initialCell = "A4"

    ' Loop through all cells
    For rowCounter = 2 To Rows.Count

        If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then

            colAValue = Range(initialCell).Cells(rowCounter, 1).Value
            colBValue = Range(initialCell).Cells(rowCounter, 2).Value
            colCValue = Range(initialCell).Cells(rowCounter, 3).Value
            colDValue = Range(initialCell).Cells(rowCounter, 4).Value

        ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then

            Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert

            Range(initialCell).Cells(rowCounter + 1, 1).Value = "0"

            Range(initialCell).Cells(rowCounter + 1, 2).Value = colBValue

            Range(initialCell).Cells(rowCounter + 1, 3).Value = colCValue

            Range(initialCell).Cells(rowCounter + 1, 4).Value = colDValue

            rowCounter = rowCounter + 1

        End If

        If Range(initialCell).Cells(rowCounter, 4).Value = vbNullString Then

            Range(initialCell).Cells(rowCounter, 1).Value = "0"

            Range(initialCell).Cells(rowCounter, 2).Value = colBValue

            Range(initialCell).Cells(rowCounter, 3).Value = colCValue

            Range(initialCell).Cells(rowCounter, 4).Value = colDValue

            Exit For

        End If

    Next rowCounter

End Sub

Этот код охватывает данные в связанном файле примера:

Sub CopyInsertRows()

    Dim sourceRow As Range

    Dim initialCell As String
    Dim dateColumnLetter As String
    Dim dateColumnNumber As Integer
    Dim rowCounter As Long

    ' <<< Customize this >>>
    initialCell = "A1" ' First cell of header row
    dateColumnLetter = "AA" ' Where

    ' Get column number
    dateColumnNumber = Range(dateColumnLetter & 1).Column

    ' Loop through all cells
    For rowCounter = 2 To Rows.Count

        If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then

            ' Store row values
            Set sourceRow = Range(initialCell).Range("A" & rowCounter & ":" & dateColumnLetter & rowCounter)

        ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then

            ' Insert new row
            Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert

            ' Duplicate source row
            Range(initialCell).Range("A" & rowCounter + 1 & ":" & dateColumnLetter & rowCounter + 1).Value = sourceRow.Value

            ' Replace first cell
            Range(initialCell).Range("A" & rowCounter + 1).Value = "0"

            rowCounter = rowCounter + 1

        End If

        If Range(initialCell).Cells(rowCounter, dateColumnNumber).Value = vbNullString Then

            ' Duplicate source row
            Range(initialCell).Range("A" & rowCounter & ":Y" & rowCounter).Value = sourceRow.Value

            ' Replace first cell
            Range(initialCell).Range("A" & rowCounter + 1).Value = "0"

            Exit For

        End If

    Next rowCounter

End Sub

Answer 2

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

Sub addLines()

    Dim i As Long, lr As Long, n As Long

    With Worksheets("sheet5")

        'collect last data row
        lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1

        'loop through the rows backwards, inserting rows and transferring values
        For i = lr To 3 Step -1
            If i = lr Or .Cells(i, "A") <> vbNullString Then
                n = Application.Match(1E+99, .Range("A:A").Resize(i - 1, 1))
                .Cells(i, "A").Resize(1, 4).Insert Shift:=xlDown
                .Cells(i, "A").Resize(1, 4) = .Cells(n, "A").Resize(1, 4).Value
                .Cells(i, "A") = 0
            End If
        Next i

    End With

End Sub