添加新行并将数据复制到该行答案

【问题标题】：Add New Row and Copy Data To That Row添加新行并将数据复制到该行
【发布时间】：2013-10-31 21:07:46
【问题描述】：

我正在寻求在 VBA 中创建新行的帮助。 A:C 列是一般项目，D:F 列是 A:C 列中的 VBA 公式驱动值。（基本上是 If Then 语句）

为了进行分析，我们的系统要求满足每个条件的单个订单项。第 1 行符合两个标准； “查询”和“高”。所以我需要在下面插入一个新行，从第 1 行 A:C 复制数据，然后在 D 列中输入“High”。这样，“Inq”和“High”就有一行数据。

将针对每一行重复该过程，不包括新添加的行。抱歉，这可能有点棘手，但我会尽我所能提供帮助。我是 Stackoverflow 的新手，所以我无法发布我的桌子的图片。

----下面是更新----

下面的代码非常适合第 19 列。它插入了行，在新行中插入了值，并将“Lead”放在最后一列。

Sub AddRow()

Dim RowIndex As Long
Dim Delta As Long

RowIndex = 2

Do While Sheets("WeeklyReport").Cells(RowIndex, 1).Value <> ""
Delta = 0
        If Sheets("WeeklyReport").Cells(RowIndex, 19).Value = "Lead" Then
        ' Inserts new row
        Sheets("WeeklyReport").Cells(RowIndex + Delta + 1, 1).EntireRow.Insert
        ' Takes cells value from row above and enters value in new row
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 1), Cells(RowIndex + 1, 17)).Value = Sheets("WeeklyReport").Range(Cells(RowIndex, 1), Cells(RowIndex, 17)).Value
        ' Puts rating value in last column
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 18), Cells(RowIndex + 1, 18)).Value = "Lead"
        Delta = Delta + 1
        End If
    RowIndex = RowIndex + Delta + 1
Loop
End Sub

由于我在 RowIndex 中有多个潜在值，我假设我可以复制第一个 If 语句，为下一列修改它，一切都会正常工作（参见下面的代码）。当我运行它时，它插入了两行，只有一行向下复制，另一行空白。

问题似乎在于每个 RowIndex 是否有多个值。我将有可能为每个 RowIndex 生成多个值，我想在其中为每个值创建一个单独的行。请参见代码下方的示例。

这是我一直在使用的代码子 AddRow()

Dim RowIndex As Long
Dim Delta As Long

RowIndex = 2

Do While Sheets("WeeklyReport").Cells(RowIndex, 1).Value <> ""
Delta = 0
        If Sheets("WeeklyReport").Cells(RowIndex, 19).Value = "Lead" Then
        ' Inserts new row
        Sheets("WeeklyReport").Cells(RowIndex + Delta + 1, 1).EntireRow.Insert
        ' Takes cells value from row above and enters value in new row
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 1), Cells(RowIndex + 1, 17)).Value = Sheets("WeeklyReport").Range(Cells(RowIndex, 1), Cells(RowIndex, 17)).Value
        ' Puts rating value in last column
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 18), Cells(RowIndex + 1, 18)).Value = "Lead"
        Delta = Delta + 1
    End If
        If Sheets("WeeklyReport").Cells(RowIndex, 20).Value = "HP" Then
        ' Inserts new row
        Sheets("WeeklyReport").Cells(RowIndex + Delta + 1, 1).EntireRow.Insert
        ' Takes cells value from row above and enters value in new row
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 1), Cells(RowIndex + 1, 17)).Value = Sheets("WeeklyReport").Range(Cells(RowIndex, 1), Cells(RowIndex, 17)).Value
        ' Puts rating value in last column
        Sheets("WeeklyReport").Range(Cells(RowIndex + 1, 18), Cells(RowIndex + 1, 18)).Value = "HP"
        Delta = Delta + 1
     End If
    RowIndex = RowIndex + Delta + 1
Loop
End Sub

示例值 - 下面不是代码，也没有在宏中使用，仅用于示例

Example: (RowIndex) A1-A17   Column 19 = "Lead", Column 20 = "HP", Column 21 = "QL"
Output:  (RowIndex) A1-A17   Column 18 = "Lead"
         (RowIndex) A1-A17   Column 18 = "HP"
         (RowIndex) A1-A17   Column 18 = "QL"

【问题讨论】：

您是否尝试过录制宏并编辑生成的代码？通常，要求代码至少不显示某些现有代码的问题会在这里很快关闭。
The problem looks to be if the RowIndex has multiple values; for instance "Lead" in Column 19, and "HP" in Column 20 of the same row. 在这种情况下，您希望添加多少行？ 1 还是 2？
@Sam Ward 你是正确的，“Lead”和“HP”将在同一行。在这种情况下，我想创建两个 RowIndex 副本（第 1-17 列），一个用于“Lead”，一个用于“HP”。另一方面，每个 RowIndex 可能有 6-8 个值，我想为每个值创建一个新行。我上面的代码显然只针对两个值，但为了清楚起见，我对其进行了修剪。
@bjk 我给你贴了一些代码，你应该能够适应。

标签： vba excel row add

【解决方案1】：

更新：根据您问题中的代码：

它添加了Delta，当您从 RowIndex 复制该行时，我忘记放了。

Dim RowIndex As Long
Dim Delta As Long

RowIndex = 2

Do While Sheets("WeeklyReport").Cells(RowIndex, 1).Value <> ""
    Delta = 0
    If Sheets("WeeklyReport").Cells(RowIndex, 19).Value = "Lead" Then
        ' Inserts new row
        Sheets("WeeklyReport").Cells(RowIndex + Delta + 1, 1).EntireRow.Insert
        ' Takes cells value from row above and enters value in new row
        Sheets("WeeklyReport").Range(Cells(RowIndex + Delta + 1, 1), Cells(RowIndex + Delta + 1, 17)).Value = Sheets("WeeklyReport").Range(Cells(RowIndex, 1), Cells(RowIndex, 17)).Value
        ' Puts rating value in last column
        Sheets("WeeklyReport").Range(Cells(RowIndex + Delta + 1, 18), Cells(RowIndex + Delta + 1, 18)).Value = "Lead"
        Delta = Delta + 1
    End If

    If Sheets("WeeklyReport").Cells(RowIndex, 20).Value = "HP" Then
        ' Inserts new row
        Sheets("WeeklyReport").Cells(RowIndex + Delta + 1, 1).EntireRow.Insert
        ' Takes cells value from row above and enters value in new row
        Sheets("WeeklyReport").Range(Cells(RowIndex + Delta + 1, 1), Cells(RowIndex + Delta + 1, 17)).Value = Sheets("WeeklyReport").Range(Cells(RowIndex, 1), Cells(RowIndex, 17)).Value
        ' Puts rating value in last column
        Sheets("WeeklyReport").Range(Cells(RowIndex + Delta + 1, 18), Cells(RowIndex + Delta + 1, 18)).Value = "HP"
        Delta = Delta + 1
    End If

    RowIndex = RowIndex + Delta + 1
Loop
End Sub

这是我建议作为解决方案的一些代码。我没有测试它，因为我没有一组数据可以测试，也没有时间进行设置。我会说总校长很好。

替换下面代码中的<enter your test value here> 和<What you need for this test>，因为它们是您需要的实际值的占位符。

此代码在 A 列中达到空值时停止。

Dim RowIndex as long
Dim Delta as long

RowIndex=1

Do While sheets("Sheet1").cells(RowIndex,1).Value <> ""
    Delta=0
    ' For the value in column D
    if sheets("Sheet1").cells(RowIndex,4).Value=<enter your test value here> then
        'insert row
        sheets("Sheet1").cells(RowIndex+Delta+1,1).entirerow.insert

        'Put the value for your result
        sheets("Sheet1").cells(RowIndexDelta+1,1).value=<What you need for this test>

        Delta=Delta+1
    end if

    ' For the value in column E
    if sheets("Sheet1").cells(RowIndex,5).Value=<enter your test value here> then
        'insert row
        sheets("Sheet1").cells(RowIndex+Delta+1,1).entirerow.insert

        'Put the value for your result
        sheets("Sheet1").cells(RowIndexDelta+1,1).value=<What you need for this test>

        Delta=Delta+1
    end if

    ' For the value in column F        
    if sheets("Sheet1").cells(RowIndex,6).Value=<enter your test value here> then
        'insert row
        sheets("Sheet1").cells(RowIndex+Delta+1,1).entirerow.insert

        'Put the value for your result
        sheets("Sheet1").cells(RowIndexDelta+1,1).value=<What you need for this test>

        Delta=Delta+1
    end if

    RowIndex=RowIndex+Delta+1

Loop

【讨论】：

谢谢！我是 VBA 新手，所以你的概念真的很有帮助。我仍在处理一些小细节。在我进行微调时，我很可能会有一两个问题。另外，我将能够提供我正在使用的代码，因为这可能会有所帮助。
我会用这段代码写下你的价值：Sheets("WeeklyReport").range(Cells(RowIndex + 1, 3),Cells(RowIndex+1,12)).value=sheets("WeeklyReport").range(Cells(RowIndex,1),Cells(RowIndex,12)) FillDown 做了一些别的事情，我认为这不是你想要的
我在您的代码末尾添加了 .Value，效果很好！谢谢。我正在努力将其扩展到下一列，但遇到了一个问题。我已经更新了我原来的帖子。非常感谢您再次提供任何帮助。
我不明白您的更新有什么问题。你能说得更清楚些吗？
我已更新为更加明确。希望这会有所帮助。

【解决方案2】：

这里有一些代码可以帮助你走上正轨。

此代码当前在工作表 1 的 C 列中查找 foo，在 D 列中查找 bar，并在下面插入行的副本。如果 bar 和 foo 都在一行中，它将插入 2 行。

Sub InsertRow()

Dim ws As Worksheet
Set ws = Sheet1

Dim i As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


On Error GoTo err

'loop through the rows from the bottom of the sheet
For i = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row To 1 Step -1

'column C
    If ws.Cells(i, 3).Value = "foo" Then

        ws.Rows(i).Copy
        ws.Rows(i + 1).Insert Shift:=xlDown

    End If

    'Column D
    If ws.Cells(i, 4).Value = "bar" Then

        ws.Rows(i).Copy
        ws.Rows(i + 1).Insert Shift:=xlDown

    End If

Application.CutCopyMode = False
Next i


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Exit Sub

err:


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox err.Description, vbCritical, "An error occured"

End Sub

【讨论】：

代码看起来复制了整行。我只想从上面的行中复制第 1-18 列。我还在原始帖子中更新了我的代码，这可能会有所帮助。
我能够修改您提供的代码。我正在运行它超过 20K 行，并且我不断收到“运行时错误 - 与客户端断开连接”。有什么想法吗？数据量大吗？我在较少的行数上测试了相同的代码，效果很好。
做到了！它遍历了所有 20K+ 行。你能解释一下你做了什么以及为什么它有帮助吗？
@bjk 我用谷歌搜索了它，有人遇到了类似的问题。他们更频繁地使用Application.CutCopyMode = False..Screenupdating 和Calculation 清除剪贴板，更改有利于加速宏。请记住在代码末尾或遇到错误时重新打开它们。如果您觉得我的回答有用，请您接受。