空白のセルと条件で行を削除するVBA

Question

私はヘッダーと空白のセルを削除する必要があるA - Sの列を持っています。ヘッダーを削除する際の参照条件は "トランザクション" & "ソース"ですが、スキップしているようです行。合計79,000行ありますが、コードは39,000までしかありません。私は私が見つけることができるすべてを試しました。まだ何も起こりません。 また、行209の書式設定と削除を開始しています。

Option Explicit 

Sub Project_M() 
Dim lastrow As Long 
Dim cc As Long 
Dim dd As Long 
lastrow = WorksheetFunction.CountA(Columns(1)) 
Application.ScreenUpdating = False 
Call ClearFormats 
lastrow = WorksheetFunction.CountA(Columns(1)) 
Columns(1).Insert shift:=xlToRight 

Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows 
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value 
Range("U209:U" & lastrow).Formula = "=IF(AND(ISERROR(SEARCH(""Transaction"",B209)),ISERROR(SEARCH(""Source"", B209))),1,0)" 
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value 

''''' delete headers : only working till row 39,0000 
Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending 
cc = WorksheetFunction.CountIf(Columns(21), "0") 
     If cc <> 0 Then 
      Range("A209:U" & cc).Select 
      Range("A209:U" & cc).EntireRow.Delete 
     lastrow = lastrow - cc 
     End If 

Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending 
Range("U:U").ClearContents 
Range("A:A").Delete 
ActiveSheet.UsedRange.Columns.AutoFit 


End Sub 

Sub deleteBlank() 'not working 
    Dim lastrow As Integer 

    lastrow = Range("A" & rows.Count).End(xlUp).Row 

    Range("B2:B" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
End Sub 

Sub ClearFormats() ' working 
    Dim rng As Range 
    Dim lastrow As Long 
    Dim ws As Worksheet 
    lastrow = Range("A" & rows.Count).End(xlUp).Row 
    Application.ScreenUpdating = False 
    On Error Resume Next 
    Set rng = Range("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks) 
    On Error GoTo 0 
    If Not rng Is Nothing Then 
    rng.ClearFormats 
    End If 

    On Error Resume Next 'not working in deleting blank cells 
ws.Columns("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 
On Error GoTo 0 

End Sub 

Sub DeleteExtra() ' not working 
Dim Last As Long 
Dim i As Long 
    Last = Cells(rows.Count, "A").End(xlUp).Row 
    For i = Last To 1 Step 1 
     If (Cells(i, "A209").Value) = "Transaction" And (Cells(i, "A209").Value) = "Source" And (Cells(i, "A209").Value) = "" And (Cells(i, "A209").Value) = " " Then 
      Cells(i, "A").EntireRow.Delete 
     End If 
    Next i 
End Sub 


Sub deleteBlankcells() '''not working 
Dim lastrow As Long 
Dim cc As Long 
lastrow = WorksheetFunction.CountA(Columns(1)) 
Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows 
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value 
Range("U209:U" & lastrow).Formula = "=IF(AND(ISBLANK(A209),ISBLANK(A209)),0,1)" 
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value 

Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending 
cc = WorksheetFunction.CountIf(Columns(21), "0") 
     If cc <> 0 Then 
      Range("A209:U" & cc).Select 
      Range("A209:U" & cc).EntireRow.Delete 
     lastrow = lastrow - cc 
     End If 

Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending 
Range("U:U").ClearContents 
Range("A:A").Delete 
End Sub 

私はさまざまな試みを試みましたが、動作しませんでした。コードはコメントされています。 ありがとう！

Answer 1

ユーザーの助けとアイデアで、私はこの簡単なコードに着目し、それを動作させました。 すべてのユーザーのクレジット乾杯！私は私の書式設定や上に移動するTo 209とStep -1の削除を開始したい行まで列for i = Lastの最後の行から開始し

Option Explicit 
Sub Project_M() 
Dim Last As Long 
Dim i As Long 
Application.ScreenUpdating = False 
    Last = cells(rows.Count, "A").End(xlUp).Row 
Range("A209:S" & Last).UnMerge 
Range("A209:S" & Last).WrapText = False 

For i = Last To 209 Step -1 
     If (cells(i, "A").Value) = "Source" Or (cells(i, "A").Value) = 0 Or (cells(i, "A").Value) = "End of Report" Or (cells(i, "A").Value) = "Transaction" Then 
      cells(i, "A").EntireRow.Delete 
     End If 
Next i 
ActiveSheet.UsedRange.Columns.AutoFit 

Application.ScreenUpdating = True 
End Sub 

。