如何根据一定数量的值删除单元格？

Question

我有大量的数据与一些混合了数字，句号和下划线的单元格。但是，我想创建一个宏，它将删除包含数字等的单元格，以便只留下包含字母表中的字母的单元格。以下是我现有的代码，但无法正常工作。我如何解决它？

Sub Sample() 
Dim ws As Worksheet 
Dim strSearch As String 
Dim Lrow As Long 


strSearch = "." 
strSearch = "0" 
strSearch = "1" 
strSearch = "2" 
strSearch = "3" 
strSearch = "4" 
strSearch = "5" 
strSearch = "6" 
strSearch = "7" 
strSearch = "8" 
strSearch = "9" 
strSearch = "." 


Set ws = Sheets("Sheet1") 

With ws 
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row 

    '~~> Remove any filters 
    .AutoFilterMode = False 

    '~~> Filter, offset(to exclude headers) and delete visible rows 
    With .Range("A1:A" & Lrow) 
     .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*" 
     .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

    '~~> Remove any filters 
    .AutoFilterMode = False 
End With 
End Sub 

我也有这个代码不能正常工作。我应该使用哪一种，我该如何解决这些问题？另外，我应该使用哪一个？

Sub Test() 
Dim cell As Range 

For Each cell In Selection 
If InStr(1, cell, "1", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
    End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "2", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
    End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "3", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "4", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "5", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "6", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "7", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "8", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "9", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, "0", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
For Each cell In Selection 
If InStr(1, cell, ".", vbTextCompare) > 0 Then 
    cell.EntireRow.Delete 
End If 
Next 
End Sub 

Answer 1

你可以试试这个：

Sub Sample() 
    Dim strSearch As Variant 

    strSearch = Array("*.*", "*0*", "*1*", "*2*", "*3*", "*4*", "*5*", "*6*", "*7*", "*8*", "*9*", "*_*") 
    With Sheets("Sheet01") 
     With .Range("A1", .Cells(.Rows.count, 1).End(xlUp)) 
      .AutoFilter Field:=1, Criteria1:=strSearch, Operator:=xlFilterValues 
      If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
     End With 
     .AutoFilterMode = False 
    End With 
End Sub 

Answer 2

这取决于你希望用这个宏来完成的。下面的宏将满足你在找什么：

Sub CleanNumerics() 
Application.ScreenUpdating = False 

Dim ws As Worksheet 
Dim r As Range 
Dim cell As Range 

Dim i As Long 
Dim j As Long 

Dim args() As Variant 

' Load your arguments into an array to allow looping 
args() = Array(".", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "_") 

' Load your selection into a range variable 
Set r = Selection 

' By stepping backwards we wont skip cells as we delete rows. 
For i = r.Cells.Count To 1 Step -1 
    ' Loop through the number of arguments in our array. 
    For j = 0 To UBound(args()) 
     ' If one of the noted characters is in the cell, the row 
     ' is deleted and the loop exits. 
     If InStr(1, r.Cells(i), args(j)) > 0 Then 
      r.Cells(i).EntireRow.Delete 
      Exit For 
     End If 
    Next 
Next 


End Sub 

这种方法的问题是，您要删除整个行可能导致取决于您的应用程序的问题。此外，如果您使用大型数据集进行此操作，则可能需要很长时间。你可以使用数组来克服这个问题，但这些可能会变得复杂。

与数组做它会是这个样子：

Sub ArrayWithoutNumbers() 
Application.ScreenUpdating = False 

Dim ws As Worksheet 
Dim r As Range 
Dim cell As Range 

Dim i As Long 
Dim j As Long 
Dim k As Long 
Dim m As Long 

Dim args() As Variant 

Dim array_1() As Variant 
Dim array_2() As Variant 

Dim flag As Boolean 

' Load your arguments into an array to allow looping 
args() = Array(".", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "_") 

' Load your selection into a range variable 
On Error GoTo Err 
array_1() = Selection.Value 
On Error GoTo 0 

' First determine if a two dimensional array has created. If so, loop through rows 
' and columns. If not, go to the other loop. 
If UBound(array_1, 2) > 1 Then 
    For i = 1 To UBound(array_1, 1) 
     For j = 1 To UBound(array_1, 2) 
      flag = False 
      For k = 0 To UBound(args()) 
       If InStr(1, array_1(i, j), args(k)) > 0 Then 
        flag = True ' Sets a flag so that the item is not added. 
        Exit For ' Exit the loop 
       End If 
      Next 

      ' If the flag hasn't been raised, resize the array and add the item. 
      If flag = False Then 
       m = m + 1 
       ReDim Preserve array_2(1 To m) 
       array_2(m) = array_1(i, j) 
      End If 
     Next 
    Next 

' Loops through only the rows of the array. 

ElseIf UBound(array_1, 2) = 1 Then 
    For i = 1 To UBound(array_1, 1) 
     For k = 0 To UBound(args()) 
      If InStr(1, array_1(i), args(k)) > 0 Then 
       flag = True 
       Exit For 
      End If 
     Next 
     If flag = False Then 
      m = m + 1 
      ReDim Preserve array_2(1 To m) 
      array_2(m) = array_1(i) 
     End If 
    Next 
End If 

' Adds a worksheet to output to. You can adjust this as needed. 

ActiveWorkbook.Sheets.Add 
ActiveSheet.Range("A1").Resize(UBound(array_2, 1), 1).Value = array_2() 

Exit Sub 

Err: 

End Sub 

的好处，这是你可以一次清理多行和列，吐了回去。