添加新行并将数据复制到该行
我正在寻找帮助在VBA中创build一个新的行。 列A：C是一般项目，列D：F是列A：C中的VBA公式驱动值。 （基本上如果这样的话）
我们的分析系统需要满足每个标准的单个项目。 第1行符合两个标准; “Inq”和“High”。 所以我需要在下面插入一个新的行，从第1行A：C复制数据，在D列input“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多个值，我想在其中创build一个单独的行。 看代码下面的例子。
这是我一直在使用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
示例值 – 下面不是代码，不是在marcro中使用，仅用于示例
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"
这里有一些代码可以帮助你走上正确的轨道。
此代码当前在表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
更新：基于你的问题在你的代码：
它添加了我从RowIndex复制行时忘记放置的Delta 。
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
这里是一些代码，我会build议作为一个解决scheme。 我没有testing，因为我没有一套数据来testing，也没有时间设置。 我会说，总的原则是好的。
在下面的代码中将<What you need for this test> <enter your test value here>和<What you need for this test>replace为您需要的实际值的占位符。
当代码到达列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