VBA根据单元格值删除整行

Question

我在使提供的VBA代码正常工作时遇到了一些问题，我们将为您提供帮助。

我有两本工作簿（1）是我收到的每月报告，其中包含多个工作表，工作表“ host_scan_data ”包含需要使用的信息来源。 我将在另一个工作簿（2）中逐月存储所有合并的日期。

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

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

我已经尝试了一些代码变体，并且当“ host_scan_data ”工作表包含少于4,000行时，其他解决方案似乎也可以正常工作，但是一旦我超过该数目（给予或接受），excel就将变得无响应。 理想情况下，此解决方案将需要处理大约150,000+行。

这是我当前正在使用的代码，当我执行它时，错误出现在“ .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

Answer 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 

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

Answer 2

我通过使用自动筛选尝试了一些不同的方法，但是在较大的列表中我看到了很高的成功率，但是仍然存在一个问题。 使用下面的代码，我能够解析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

Answer 3

您的“ MsgBox（countNum和“现在正在导入行！”）”返回正确的行数吗？ CountA将在第一个空单元格处停止计数。

尝试instread：countNum = ActiveSheet.UsedRange.Rows.Count