Question

我正在寻找帮助在VBA中创建新行。列A：C是常规项，列D：F是列A：C中的VBA公式驱动值。（基本上如果那么陈述）

我们的系统需要针对每个符合条件的单个订单项进行分析。第1行符合两个标准; “Inq”＆amp; “高”。所以我需要在下面插入一个新行，从第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多个值，我想在其中为每个RowIndex创建一个单独的行。请参阅下面的代码示例。

这是我一直在使用的代码 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"

Answer 1

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

添加从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

以下是我建议作为解决方案的一些代码。我没有测试它，因为我没有一组数据可供测试，也没有时间设置某些内容。我会说一般校长是好的。

替换下面代码中的<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

Answer 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

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

2 个答案: