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

我有大量的数据，一些单元格有数字混合，完全停止和下划线。 但是，我想要创build一个macros，它将删除包含数字等的单元格，以便只留下包含字母表中的字母的单元格。 下面是我目前的代码，但它不能正常工作。 我如何解决它？

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

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

 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 

这样做的好处是可以一次清理多行和多列，并将其吐出。