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

Question

这个网站已经有类似的东西了：Copy and insert rows based off of values in a column

但是代码并没有把我带到我需要去的地方，而且我无法对其进行调整以使其适合我。

我的用户有一个包含 4 列 A-D 的工作表。 A 列包含具体的合同编号，B 列为空白，C 列包含零件编号，D 列包含整个合同编号范围。我的用户想要计算整个范围合同编号重复的次数，因此我在单元格 E2 中输入公式 =countif($D$2:$D$100000,A2) 并复制下来，给出 A 列中特定合同出现在 D 列中的次数。数字此工作簿中的范围从 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 列中的公式，使其保持可复制且不计算复制的行。

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