如果值> 1，则在下面插入空白单元格的宏，并从上面的单元格复制/粘贴值

Question

该站点已经具有类似的功能： 根据列中的值复制和插入行

但是代码并不能将我带到需要去的地方，而且我也无法对其进行调整以使其对我有用。

我的用户有一个包含4列AD的工作表。 A列包含特定的合同编号，B列为空白，C列包含部件号，D列包含合同编号的整个范围。 我的用户想计算整个范围合同编号重复的次数，因此我在单元格E2中输入了公式=countif($D$2:$D$100000,A2)并向下复制，从而给了我特定合同的次数此工作簿中的数字在1到11之间，但在其他工作簿中此数字可能会更高，此方法将在其中使用。

我需要做的下一件事是在E列中所有大于1的值下方输入空白单元格，这非常类似于先前询问的示例。 然后，我还需要在同一行中复制并完全插入复制的单元格以使其与A列中的同一行匹配。示例：单元格E21的编号为5，因此我只需要在E列中移动单元格，以便有4个空白单元格正下方。 在A列中，我需要复制单元格A21，并在正下方的四行中插入复制的单元格。

尝试使用上一个问题中给出的代码尝试插入空白单元格是一个尝试。

    Dim sh As Worksheet
    Dim lo As ListObject
    Dim rColumn As Range
    Dim i As Long
    Dim rws As Long

    Set sh = ActiveSheet
    Set lo = sh.ListObjects("Count")

    Set rColumn = lo.ListColumns("Count").DataBodyRange
    vTable = rColumn.Value

    For i = rColumn.Rows.Count To 1 Step -1
        If rColumn.Cells(i, 1) > 1 Then
            rws = rColumn.Cells(i, 1) - 1
            With rColumn.Rows(i)
                .Offset(1, 0).Resize(rws, 1).Cells.Insert
                .EntireRow.Copy .Offset(1, 0).Resize(rws, 1).Cells
                .Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
            End With
        End If
    Next

我将一直与这个怪物作战一周，感谢您的帮助。

Answer 1

尽管确实可以做到这一点，但最好将所有合同编号列表从D列移到另一张纸上。 即使在范围内循环并根据单元格值插入行非常简单，它也会在D和E列中创建孔。

这是简单地添加行并复制指定值的代码。

Sub Main()

'---Variables---
Dim source As Worksheet
Dim startRow As Integer
Dim num As Integer
Dim val As String
Dim i As Long


'---Customize---
Set source = ThisWorkbook.Sheets(1) 'The sheet with the data
startRow = 2 'The first row containing data


'---Logic---
i = startRow 'i acts as a row counter
Do While i <= source.Range("E" & source.Rows.Count).End(xlUp).Row
'looping until we hit the last row with a value in column E
    num = source.Range("E" & i).Value 'Get number of appearances
    val = source.Range("A" & i).Value 'Get the value
    If num > 1 Then 'Number of appearances > 1
        Do While num > 1 'Create rows
            source.Range("A" & i + 1).EntireRow.Insert 'Insert row
            source.Range("A" & i + 1) = val 'Set value
            num = num - 1
            i = i + 1 'Next row
        Loop
    End If
    i = i + 1 'Next row
Loop

End Sub

当然，您还可以在插入新行之后删除D列中的孔，并修改E列中的公式，以使其保持可复制性，并且不为复制的行计算。

通常，如果可以将单个行视为单个对象，则使事情变得容易，因为创建或删除一行仅会影响该单个对象。 在这里，我们有一行既代表特定合同，又代表所有合同列表中的合同-这可能最终会在以后引起麻烦（或者可能完全没问题！）