VBA根据单元格值删除整行答案

【问题标题】：VBA to delete entire row based on cell valueVBA根据单元格值删除整行
【发布时间】：2016-09-06 16:28:06
【问题描述】：

我在使提供的 VBA 代码正常工作时遇到了一些问题，希望能提供任何帮助。

我有两个工作簿 (1) 是我收到的包含多个工作表的月度报告，工作表“host_scan_data”包含我需要处理的信息的来源。另一个工作簿 (2) 是我将每月存储所有合并日期的地方。

我是如何尝试完成这项任务的： 1. 启动工作簿 #2 2. 单击分配有以下 VBA 代码的按钮（见下文） 3. 浏览并选择我的月度报告（工作簿 #1） 4. 在工作簿#2 中指定工作表选项卡，我想在其中存储此合并信息 5. 提示用户验证将存储数据的工作表选项卡

然后根据上面的响应，宏将分析工作簿 (1) 的“host_scan_data”表中的列 K，我希望将其删除Column k 包含“0”的所有行（注意我关心的唯一值是 4,3,2,1）。一旦该操作完成，我希望宏将合并的条目列表复制到上面步骤＃4中指定的位置。

我已经尝试了一些代码变体，当“host_scan_data”工作表包含

这是我当前正在使用的代码，当我执行它时出现错误“.Sort .Columns(cl + 1), Header:=xlYes”：

到目前为止我的代码：

Sub Import()
 Dim strAnswer
 Dim itAnswer As String
 Dim OpenFileName As String
 Dim wb As Workbook
 Dim db As Workbook
 Dim Avals As Variant, X As Variant
 Dim i As Long, LR As Long

 'Optimize Code
  Call OptimizeCode_Begin

 'Select and Open workbook
 OpenFileName = Application.GetOpenFilename("*.xlsx,")
 If OpenFileName = "False" Then Exit Sub
 Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
 Set db = ThisWorkbook

 'Provide Sheet Input
    strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")

    If strAnswer = "" Then

        MsgBox "You must enter a valid name. Exiting now..."
        wb.Close
        Exit Sub
    Else

        Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
        If Response = vbNo Then
            MsgBox "Got it, you made a mistake. Exiting now..."
            wb.Close
            Exit Sub
        Else: MsgBox "Importing Now!"
        End If
    End If

    wb.Sheets("host_scan_data").Activate
            Dim rs, cl, Q()
            Dim arr1, j, C, s As Long

            Dim t As String: t = "4"
            Dim u As String: u = "3"
            Dim v As String: v = "2"
            Dim w As String: w = "1"

            If Cells(1) = "" Then Cells(1) = Chr(2)
            'Application.Calculation = xlManual
            rs = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByRows, xlPrevious).Row
            cl = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByColumns, xlPrevious).Column
            ReDim Q(1 To rs, 1 To 1)
            arr1 = wb.Sheets("host_scan_data").Cells(1, "k").Resize(rs)
            For j = 1 To rs
                C = arr1(j, 1)
                If (C <> t) * (C <> u) * (C <> v) * (C <> w) Then Q(j, 1) = 1: s = s + 1
            Next j
            If s > 0 Then
                With Cells(1).Resize(rs, cl + 1)
                    .Columns(cl + 1) = Q
                    .Sort .Columns(cl + 1), Header:=xlYes
                    .Cells(cl + 1).Resize(s).EntireRow.Delete
                End With
            End If

            countNum = (Application.CountA(Range("B:B"))) - 1
            MsgBox (countNum & " Rows being imported now!")
            countNum = countNum + 2
            db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
            db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
            db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
            db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
            db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
            db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
            db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
            db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
            MsgBox ("Done")
            'Close nessus file
            wb.Close SaveChanges:=False
        'Else
            'MsgBox "You must enter 1 or 2 only. Exiting now..."
            'wb.Close
            'Exit Sub
   'End If



 Sheets(strAnswer).Select

 'Optimize Code
  Call OptimizeCode_End

End Sub

【问题讨论】：

究竟是什么错误？
请阅读How to Ask，而不是这个很长的问题，并将您的问题编辑到解决问题所需的最少信息量。
好吧，我很困惑，但我认为这条线很糟糕：
将必要的范围写入一个数组，循环计算您需要多少项目，调整另一个数组的大小以容纳所有项目，然后将您需要的内容输出到新数组，然后用新数组。然后您实际上不必删除行。实际上删除这么多行需要很长时间。
好吧，结果不太好。除了你的问题，“lastRow = wb.Sheets("host_scan_data").Range("K" & wb.Sheets("host_scan_data").Rows.Count).End(xlUp).row" 对我来说似乎很复杂。为什么不只是 "lastRow = wb.Sheets("host_scan_data").cells(rows.count, "K").End(xlUp).row"

标签： vba excel macros

【解决方案1】：

所以这就是可能发生的事情。

如果您要删除的行使用了数据，则在其他地方的公式中，该公式将在行删除的每次迭代中重新计算。

我的数据集有很多 Vlookup 函数提取数据时遇到了这个问题。

这是我所做的，它需要几秒钟而不是 30 分钟

Sub removeLines()
Dim i As Long
Dim celltxt As String
Dim EOF As Boolean
Dim rangesize As Long
EOF = False
i = 1
'My data has "End of File" at the end so I check for that 
' Though it would be better to used usedRange
While Not (EOF)
    celltxt = ActiveSheet.Cells(i, 1).Text 
    If InStr(1, celltxt, "end", VbCompareMethod.vbTextCompare) > 0 Then
       EOF = True 'if we reach the "end Of file" then exit

' so I clear a cell that has no influence on any functions thus 
' it executes quickly
    ElseIf InStr(1, celltxt, "J") <> 1 Then
        Cells(i, 1).Clear
    End If
    i = i + 1
Wend
' once all the rows to be deleted are marked with the cleared cell
' I use the specialCells to select and delete all the rows at once
' so that the dependent formula are only recalculated once 
    Columns("A:A").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

希望这会有所帮助并且可以阅读

【讨论】：

【解决方案2】：

我通过使用 AutoFilter 尝试了一些不同的方法，我在较大的列表中看到了很高的成功率，但是仍然存在一个问题。使用下面的代码，我能够解析 67k+ 行并过滤/删除在我的 K 列中包含“0”的任何行（这需要大约 276 秒才能完成），在代码过滤并删除带有零的行之后，它会清除任何然后现有的过滤器将剩余的数据复制到我的工作簿#2（这大约是 7k 行）但是它始终只将 17 行数据复制到我的工作簿#2，它似乎停止了，我不知道为什么。此外，虽然可以接受 4.5 分钟完成整合，但有人对如何加快整合有任何想法吗？

Sub Import()
 Dim strAnswer
 Dim itAnswer As String
 Dim OpenFileName As String
 Dim wb As Workbook
 Dim db As Workbook
 Dim Avals As Variant, X As Variant
 Dim i As Long
 Dim FileLastRow As Long
 Dim t As Single
 Dim SevRng As Range
 t = Timer

 'Optimize Code
  Call OptimizeCode_Begin

 'Select and Open workbook
 OpenFileName = Application.GetOpenFilename("*.xlsx,")
 If OpenFileName = "False" Then Exit Sub
 Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
 Set db = ThisWorkbook

 'Provide Sheet Input
    strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")

    If strAnswer = "" Then

        MsgBox "You must enter a valid name. Exiting now..."
        wb.Close
        Exit Sub
    Else

        Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
        If Response = vbNo Then
            MsgBox "Got it, you made a mistake. Exiting now..."
            wb.Close
            Exit Sub
        Else: MsgBox "Importing Now!"
        End If
    End If

    FileLastRow = wb.Sheets("host_scan_data").Range("K" & Rows.Count).End(xlUp).Row
    Set SevRng = wb.Sheets("host_scan_data").Range("K2:K" & FileLastRow)

    Application.DisplayAlerts = False
    With SevRng
        .AutoFilter Field:=11, Criteria1:="0"
        .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
        .Cells.AutoFilter
    End With

    Application.DisplayAlerts = True

    MsgBox "Consolidated in " & Timer - t & " seconds."

            countNum = (Application.CountA(Range("B:B"))) - 1
            MsgBox (countNum & " Rows being imported now!")
            countNum = countNum + 2
            db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
            db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
            db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
            db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
            db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
            db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
            db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
            db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
            MsgBox ("Done")
            'Close nessus file
            wb.Close SaveChanges:=False

 Sheets(strAnswer).Select

 'Optimize Code
  Call OptimizeCode_End

End Sub

【讨论】：

【解决方案3】：

你的 "MsgBox (countNum & " 正在导入的行数！")" 返回正确的行数？ CountA 将在第一个空单元格处停止计数。

尝试插入： countNum = ActiveSheet.UsedRange.Rows.Count

【讨论】：