1

我正在寻求帮助在 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 生成多个值，我想在其中为每个值创建一个单独的行。请参见代码下方的示例。

这是我一直在使用 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: (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"
4

2 回答 2

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
于 2013-10-31T21:32:07.903 回答
0

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

此代码当前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
于 2013-11-06T14:09:47.997 回答