Question

我有一个用于粘贴制表符分隔数据并根据最后一列添加颜色代码的宏。我的问题是我试图通过删除最后一列为1-5的行来压缩数据。但是，此条件下的行不做任何事情。我已经确认它使用msgbox在正确的行上运行。我有什么遗失的吗？

ActiveWorkbook.Save
Application.ScreenUpdating = False

Dim x, rowStart, colStart As Integer
    Dim rng As Range
    Set rng = Range(Selection.Address)

    colStart = rng.Column
    rowStart = rng.Row

rng.PasteSpecial

Set rng = Range(Selection.Address)

Selection.TextToColumns Destination:=rng, DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
    TrailingMinusNumbers:=True

For x = (rowStart + 1) To (rowStart + Application.WorksheetFunction.CountA(Selection) - 1)
    If ActiveSheet.Cells(x, colStart + 13) = "0" Then
        ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).Style = "Good"
    ElseIf ActiveSheet.Cells(x, colStart + 13) > 0 And ActiveSheet.Cells(x, colStart + 13) < 6 Then
        ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).EntireRow.Delete
    ElseIf ActiveSheet.Cells(x, colStart + 13) = "6" Or ActiveSheet.Cells(x, colStart + 13) = "7" Then
        ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).Style = "Neutral"
    ElseIf ActiveSheet.Cells(x, colStart + 13) > 7 Then
        ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).Style = "Bad"
    End If

    If ActiveSheet.Cells(x, colStart + 13) = "-" Then
        ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 12)).Style = "Normal"
    End If

Next

ActiveSheet.Cells(rowStart, colStart).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

With Selection.Font
    .Name = "Calibri"
    .Size = 10
End With

ActiveSheet.Cells(rowStart, colStart + 4).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

With Selection
    .HorizontalAlignment = xlRight
End With

ActiveSheet.Cells(rowStart, colStart).Select

Application.ScreenUpdating = True

End Sub

Answer 1

假设您删除第2行，下一个x值将为3.同时，其余数据将向上移动一行。下一行将被跳过，因为即使你想要评估最初的第3行，它现在取代了删除的第2行。

row 1 a
row 2 b <---meets condition, delete , x = 2
row 3 c
row 4 d

下一个x

row 1 a
row 2 c <--skipped
row 3 d <--next iteration, x = 3

解决方法是在删除x减去x

后放入一行

ElseIf ActiveSheet.Cells(x, colStart + 13) > 0 And ActiveSheet.Cells(x, colStart + 13) < 6 Then
    ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).EntireRow.Delete
    x = x - 1
ElseIf ActiveSheet.Cells(x, colStart + 13) = "6" Or ActiveSheet.Cells(x, colStart + 13) = "7" Then
    ActiveSheet.Range(ActiveSheet.Cells(x, colStart), ActiveSheet.Cells(x, colStart + 13)).Style = "Neutral"
ElseIf

更好的解决方案是使用while循环，这样就不必在末尾迭代任何空行。

Answer 2

删除或添加行时，应始终向后循环以避免跳过行。

将循环声明更改为：

For x = (rowStart + Application.WorksheetFunction.CountA(Selection) - 1) To rowStart + 1) Step -1

这告诉代码从底部开始并向后循环到顶部。这将确保根据需要删除所有行。

请尝试使用以下代码：

ActiveWorkbook.Save
Application.ScreenUpdating = False

Dim x As Long
Dim rng As Range
Set rng = Selection

rng.PasteSpecial

rng.TextToColumns Destination:=rng, DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
    TrailingMinusNumbers:=True

For x = (rowStart + WorksheetFunction.CountA(Selection) - 1) To (rowStart + 1) Step -1
    Select Case Cells(x, rng.Column + 13).value
        Case "0": Range(Cells(x, rng.Column), Cells(x, rng.Column + 13)).Style = "Good"
        Case 1 To 5: Rows(x).EntireRow.Delete
        Case 6, 7: Range(Cells(x, rng.Column), Cells(x, eng.Column + 13)).Style = "Neutral"
        Case Is > 7: Range(Cells(x, rng.Column), Cells(x, eng.Column + 13)).Style = "Bad"
        Case "-": Range(Cells(x, rng.Column), Cells(x, eng.Column + 13)).Style = "Normal"
    End Select
Next

With rng.CurrentRegion.Font
    .Name = "Calibri"
    .Size = 10
End With

With rng
    Range(Cells(.Row, .Column + 4), .Cells(.Cells.count)).HorizontalAlignment = xlRight
End With


Application.ScreenUpdating = True

使用VBA宏删除特定行

2 个答案: