Question

以下代码旨在当M列中的值为“不可用”时删除每一行。来自表＆＃39;摘要＆＃39;并将整行放在另一张表格中。摘要选项＆＃39;。我想在countif函数中添加一个参数，例如同时删除M列中值为的每一行作为＆＃39;进行调查＆＃39;。除了创建新代码并替换我需要的内容外，我该怎么办？

Sub removing_rows()
Dim Check As Range, lastrow As Long, lastrow2 As Long
lastrow = Worksheets("Summary").UsedRange.Rows.Count
lastrow2 = Worksheets("Summarybis").UsedRange.Rows.Count
If lastrow2 = 1 Then
lastrow2 = 0
Else
End If
Do While Application.WorksheetFunction.CountIf(Range("M:M"), "Non Available") > 0
Set Check = Range("M2:M" & lastrow)
For Each Cell In Check
    If Cell = "Non Available" Then
        Cell.EntireRow.Copy Destination:=Worksheets("Summarybis").Range("A" & lastrow2 + 1)
        Cell.EntireRow.Delete
        lastrow2 = lastrow2 + 1
        Else:
    End If
Next
Loop
End Sub

最后，我认为上面的代码并没有完全定义，因为可能会发生没有产生输出（表格中没有填写任何内容＆＃39; Summarybis＆＃39;）。我错过了什么？

提前非常感谢！：）

Answer 1

正如@Victor K建议尝试使用countifs并且不要忘记添加条件，如果关于＆＃39;要调查＆＃39;

Sub removing_rows()
Dim Check As Range, lastrow As Long, lastrow2 As Long
lastrow = Worksheets("Summary").UsedRange.Rows.Count
lastrow2 = Worksheets("Summarybis").UsedRange.Rows.Count

Do While ((Application.WorksheetFunction.CountIf(Range("M:M"), "Non Available") + Application.WorksheetFunction.CountIf(Range("M:M"), "To investigate")) > 0)
Set Check = Sheets("Summary").Range("M1:M" & lastrow)
For Each Cell In Check
Select Case True
    Case Cell = "Non Available"
    Cell.EntireRow.Copy Destination:=Worksheets("Summarybis").Range("A" & lastrow2 + 1)
    Cell.EntireRow.Delete
    lastrow2 = lastrow2 + 1
    Case Cell = "To Investigate"
    Cell.EntireRow.Copy Destination:=Worksheets("Summarybis").Range("A" & lastrow2 + 1)
    Cell.EntireRow.Delete
    lastrow2 = lastrow2 + 1
End Select
Next
Loop
End Sub

Answer 2

我不是很清楚一点：我还想从M栏中的工作表'摘要'中删除值为'调查'的行，并将它们放在工作表'Summarybis'中。

我尝试过以下内容（根据林肯的回答）：

Sub removing_rows()
Dim Check As Range, lastrow As Long, lastrow2 As Long
lastrow = Worksheets("Summary").UsedRange.Rows.Count
lastrow2 = Worksheets("Summarybis").UsedRange.Rows.Count
If lastrow2 = 1 Then
lastrow2 = 0
Else
End If
Do While ((Application.WorksheetFunction.CountIf(Range("M:M"), "Non Available") + Application.WorksheetFunction.CountIf(Range("M:M"), "To investigate")) > 0)
Set Check = Range("M2:M" & lastrow)
For Each Cell In Check
Select Case True
    Case Cell = "Non Available"
    Cell.EntireRow.Copy Destination:=Worksheets("Summarybis").Range("A" & lastrow2 + 1)
    Cell.EntireRow.Delete
    lastrow2 = lastrow2 + 1
    Case Cell = "To Investigate"
    Cell.EntireRow.Copy Destination:=Worksheets("Summarybis").Range("A" & lastrow2 + 1)
    Cell.EntireRow.Delete
    lastrow2 = lastrow2 + 1
End Select
Next
Loop
End Sub

但是Excel很冷，没有输出..任何人都有想法？：）

Answer 3

如果您仍需要，请查找更正后的代码版本：

Option Explicit

Sub removing_rows()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim Check As Range, cell As Range
Dim rngS As Worksheet, rngSbis As Worksheet
Dim lastrow As Long, lastrow2 As Long, i As Long
Dim ro() As Integer, drow As Integer
Const key_word1 = "TO INVESTIGATE"
Const key_word2 = "NON AVAILABLE"

Set rngS = ThisWorkbook.Worksheets("Summary")
Set rngSbis = ThisWorkbook.Worksheets("Summarybis")

'Storing last rows to the varibles for future use
lastrow = rngS.UsedRange.Rows.Count + 1

ReDim Preserve ro(lastrow)
i = 0
'Copy of all rows that contains key words to the 'S' tab
Set Check = rngS.Range("M2:M" & lastrow)
For Each cell In Check
Select Case True
    Case UCase(cell.Value2) = key_word2
    cell.EntireRow.Copy
    rngSbis.Cells(rngSbis.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    ro(i) = cell.Row
    i = i + 1
    Case UCase(cell.Value2) = key_word1
    cell.EntireRow.Copy
    rngSbis.Cells(rngSbis.Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    ro(i) = cell.Row
    i = i + 1
End Select
Next
'Deleting all rows with key words
For i = UBound(ro) To LBound(ro) Step -1
    On Error Resume Next
    rngS.Rows(ro(i)).Delete
Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

VBA - 在countif中添加参数

3 个答案: