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

Add New Row and Copy Data To That Row

提问by bjk

I am looking for help creating a new row in VBA. Columns A:C are general items, Columns D:F are VBA formulas driven values in Columns A:C. (Basically If Then statements)

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

Our system, for analysis, requires a single line item for each criteria met. Row 1 meets two criteria; "Inq" & "High". So I need to insert a new row below, copy the data from row 1 A:C, and in column D enter "High". That way there is a single row of data for "Inq" and "High".

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

The process would be repeated for every row, excluding the newly added ones. Sorry, this may be a little tricky, but I will help out anyway I can. I am new to Stackoverflow so I couldn't post an image of my table.

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

---- Below is an update ----

---- 以下是更新----

The code below worked great for Column 19. It inserted the row, inserted the values in the new row, and place "Lead" in the last column.

下面的代码非常适合第 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

Since I have multiple potential values in the RowIndex, I assumed I could just copy the first If Statement, modify it for the next column and everything will work (see code below). When I ran it, it inserted two rows, only one row copied down, the other blank.

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

The problem seems to be if there are multiple values per RowIndex. I will have the potential for multiple values per RowIndex, in which I would like to create a separate row for each. See example below the code.

问题似乎是每个 RowIndex 是否有多个值。我将有可能为每个 RowIndex 设置多个值，我想为每个值创建一个单独的行。请参阅代码下方的示例。

Here is my code that I have been working with Sub AddRow()

这是我一直在使用 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
        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 Values - Below is not code, and not used in the marcro, example only

示例值 - 以下不是代码，也没有在宏中使用，仅作为示例

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"

采纳答案by Sam

Here is some code that may help you get on the right track.

下面是一些可以帮助您走上正轨的代码。

This code currently looks for fooin column C of sheet 1 and barin column D and inserts a copy of the row underneath. It will insert 2 rows if both bar and foo exist in a row.

此代码当前foo在工作表 1 的 Cbar列和 D列中查找，并在下方插入该行的副本。如果 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

回答by Michel

UPDATE: Based on your code in your question:

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

It add the DeltaI forgot to put when you copy the line from RowIndex.

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

---

---

Here is some code I would suggest as a solution. I didn't test it because I do not have a set of data to test with nor have the time to set somehting up. I would say that the general principal is good.

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

Replace <enter your test value here>and <What you need for this test>in the code below as they are place holder for the actual value you need.

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

This code stop when it reaches a empty value in column A.

此代码在 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