VBA，有一几十万行的EXCEL表格。需要删除满足多条件之一的行。 250
程序1：有一excel表格，有几十万行。用vba一次性删除满足多条件之一的行：只要单元格中的数据是1、2、5、8、11、14、19中的任意一个，则删除该单元格所在的整行。
程序2：有一excel表格，有几十万行。用vba一次性删除满足多条件之一的行：只要某行的所有单元格中的数据均不是1、2、5、8、11、14、19中的任意一个数据，则删除该整行。
请将代码备注一下，便于条件变化时我好自己修改。谢谢 展开
Sub test()
Dim str As String, rng As Range
Dim dic As Object, valDic As Object
str = "1、2、5、8、11、14、19" '这里是条件，顿号分割，别写错了
Set dic = CreateObject("scripting.dictionary")
Set valDic = CreateObject("scripting.dictionary")
temp = Split(str, "、")
For i = 0 To UBound(temp)
valDic(temp(i)) = ""
Next
With ActiveSheet
Set rng = .UsedRange
arr = rng
For i = LBound(arr, 1) To UBound(arr, 1)
If Not CellNeedRemove(arr, valDic, i) Then '方法2：把这一行改为 if not RowNeedRemove(arr,valdic,i) then
dic(i) = ""
End If
Next
If dic.Count < UBound(arr, 1) - LBound(arr, 1) Then
rng.ClearContents
If dic.Count = 0 Then Exit Sub
Dim newArray()
ReDim newArray(1 To dic.Count, 1 To UBound(arr, 2))
Dim n As Integer
n = 1
For Each rowNum In dic.keys
For i = LBound(arr, 2) To UBound(arr, 2)
newArray(n, i) = arr(rowNum, i)
Next
n = n + 1
Next
rng.Cells(1, 1).Resize(dic.Count, UBound(arr, 2) - LBound(arr, 2)) = newArray
End If
End With
End Sub
Private Function CellNeedRemove(ByVal arr, ByVal dic, ByVal rowIndex) As Boolean
For i = LBound(arr, 2) To UBound(arr, 2)
If dic.exists(arr(rowIndex, i) & "") Then
CellNeedRemove = True
Exit Function
End If
Next
CellNeedRemove = False
End Function
Private Function RowNeedRemove(ByVal arr, ByVal dic, ByVal rowIndex) As Boolean
For i = LBound(arr, 2) To UBound(arr, 2)
If dic.exists(arr(rowIndex, i) & "") Then
RowNeedRemove = False
Exit Function
End If
Next
RowNeedRemove = True
End Function
我的理解是不是对，你这两个程序所获得的数据，其实是互为补集，即：程序1里要删除的，就是程序2里要保留的；程序1里要保留的，就是程序2里要删除的。
假设数据表都是6列，且程序1里的数据在数据表1里面；
我想是不是两个程序可以用一个程序来完成，按照程序1的要求，如果找到满足的行，先把该行复制到数据表2，然后在数据表1里删除改行。
这样数据表1留下的就是满足程序1的数据，而数据表2里就是满足程序2的数据。
具体代码如下：
Sub 移动与删除()
Dim KeyStr As String
Dim MyRow1 As Integer, MyRow2 As Integer
Dim MyCol As Integer
Dim i As Integer
Dim YesNo As Boolean
KeyStr = "[1]、[2]、[5]、[8]、[11]、[14]、[19]"
MyRow1 = 1
MyRow2 = 0
Do While Sheets("Sheet1").Cells(MyRow1, 1) <> ""
For MyCol = 1 To 6
If InStr(KeyStr, "[" & Sheets("Sheet1").Cells(MyRow1, MyCol).Value & "]") <> 0 Then
'先把该行复制到数据表2
MyRow2 = MyRow2 + 1
For i = 1 To 6
Sheets("Sheet2").Cells(MyRow2, i).Value = Sheets("Sheet1").Cells(MyRow1, i).Value
Next i
Sheets("Sheet1").Rows(MyRow1).Delete
Exit For
End If
Next MyCol
If MyCol > 6 Then MyRow1 = MyRow1 + 1
Loop
End Sub
不是那样的，那几个条件数字我只是举例，实际应用的时候，两个程序的条件数据不会完全相同的。
所以，还是需要两个程序
6列
Sub 删行1()
'此段代码只要A列数据满足条件之一即删除整行。
Dim i As Long '定义i为长整数
s = Range("A300000").End(3).Row '赋值s等于单元格A300000上方的最后一个数据所在的行数
For i = s To 1 Step -1 '从第s行至第1行，步长为-1,即从第s行向上逐行
If Evaluate("SUMPRODUCT(--(A" & i & "={1,2,5,8,11,14,19}))") = 1 Then '条件为A列单元格
Range("A" & i).EntireRow.Delete '满足以上条件之一时删除整行
End If
Next
MsgBox "运行完毕！" '弹出结束提示
End Sub
Sub 删行2()
'此段代码只要A列至F列数据全不是所列出的数字时即删除整行。
Dim i As Long '定义i为长整数
s = Range("A300000").End(3).Row '赋值s等于单元格A300000上方的最后一个数据所在的行数
For i = s To 1 Step -1 '从第s行至第1行，步长为-1,即从第s行向上逐行
If Evaluate("SUMPRODUCT(--(A" & i & ":F" & i & "={1;2;5;8;11;14;19}))") = 0 Then '条件为A列至F列的单元格
Range("A" & i).EntireRow.Delete '满足以上条件时删除整行
End If
Next
MsgBox "运行完毕！" '弹出结束提示
End Sub
