Question

我有来自A-S的列，我需要删除标题和空白单元格，我在删除标题中查找的条件是“交易”＆amp; “来源”，但它似乎正在跳过行。我总共有79,000行，但代码只有39,000行。我已经尝试了我能找到的一切。仍然没有任何反应我也开始格式化并删除第209行到lastrow。

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

借助用户的帮助和想法，我已经开始使用这个简单的代码并使其正常运行。给所有人的信誉！干杯！

 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

从列for i = Last的最后一行开始直到我要开始格式化的行，并删除To 209和Step -1以便向上移动。

删除包含空白单元格和条件VBA的行

1 个答案: