すべての空白行を削除しますが、2つの空白行を残します。

Question

空白の行を削除しますが、空白の行は2つ残します。ここに私のコードは、これまでです：

Sheets("XYZ").Select 
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
Do Until blanks.Columns.Count = 2 
Loop 
End Sub 

Answer 1

を私はこれを行うには良い方法があるかもしれないと思うが、あなたの質問に応じて、これを試してみてください。

の変化は、私はそれに応じて、3 =の2blanksなぜあなただ​​けのすべての空白行を削除したが、その後最後に2を挿入していない

Dim blankRows As Integer 
Dim i As Integer 
With Sheets("Sheet1").UsedRange 
    blankRows = .Columns(1).SpecialCells(xlCellTypeBlanks).Count 

    For i = 3 To blankRows 
     Columns(1).Cells.SpecialCells(xlCellTypeBlanks)(1).EntireRow.Delete 
    Next i 
End With 

Answer 2

あなたはこの試みることができる：

Sub main() 
    Dim lastCell As Range 
    Dim blanksCount As Long 
    Dim iarea As Long, icell As Long 

    With Worksheets("XYZ") 
     With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks) 
      For iarea = .Areas.Count To 1 Step -1 
       For icell = .Areas(iarea).Count To 1 Step -1 
        blanksCount = blanksCount + 1 
        If blanksCount = 2 Then 
         Set lastCell = .Areas(iarea).Cells(icell).Offset(-1) 
         Exit For 
        End If 
       Next 
       If Not lastCell Is Nothing Then Exit For 
      Next 
     End With 
     .Range("A1", lastCell).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
    End With 
End Sub