Удаление определенных строк с помощью макроса VBA

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 

следующая х

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

решение поставить в линию после того, как вы удалите что декрементирует х

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 

Лучшим решением было бы использовать время цикла, так вы не «Мне нужно перебирать все пустые строки в конце.

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