Question

如果可以的话，有人可以帮我吗？

逻辑是：如果ColA = 1且ColC> = 1，则它应复制整行并在最后一个空白单元格下方插入新行，然后再遇到包含1的下一个单元格，则该行将变为0。

原始：

input

最终输出应为：

Output

我试图将其作为文本输入，但似乎不正确。我现在拥有的代码仅仅是这个，这是我的第一个项目。我的代码仍然不完整，因为我不知道下一步该怎么做。我尝试了很多代码，但是没有用。这是代码：

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

您将插入行，因此从下至上进行工作。

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

Answer 2

这是另一种方法。考虑到您下面可能有数据， 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

在遇到下一个单元格之前，将空白单元格上方的数据复制到最后一个空白单元格

2 个答案: