VBA根据单元格值删除整行

时间:2016-09-06 16:28:07

标签: excel vba excel-vba macros

我在提供VBA代码时遇到了一些问题,并希望得到任何帮助。

我有两个工作簿(1)是我收到的月度报告,其中包含多个工作表,工作表" host_scan_data "包含我需要使用的信息的来源。另一个工作簿(2)是我将存储所有合并日期月份的地方。

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

根据上述回复,宏将分析" host_scan_data "中的列K 。工作簿(1)的工作表,我希望它删除列k 包含" 0" (注意我唯一关心的值是4,3,2,1)。一旦该操作完成,我希望宏将整合的条目列表复制到上面步骤#4中指定的位置。

我已尝试使用一些代码变体,其他解决方案似乎在" host_scan_data "工作表包含< 4,000行但是一旦我超过该数量(给予或接受),excel就会变得没有响应。理想情况下,此解决方案需要处理大约150,000多行。

以下是我目前使用的代码,当我执行时错误输出" .Sort .Columns(cl + 1),标题:= 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

3 个答案:

答案 0 :(得分:0)

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

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

我遇到了一个数据集的问题,该数据集有很多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

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

答案 1 :(得分:0)

我尝试使用AutoFilter采用了一种不同的方法,并且我在较大的列表上看到了很高的成功率,但仍有一个问题。使用下面的代码,我能够解析67k +行并过滤/删除任何包含&#34; 0&#34;在我的列K中(这需要大约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

答案 2 :(得分:0)

你的 “MsgBox(countNum&amp;”行正在导入!“)” 返回正确的行数? CountA将在第一个空单元处停止计数。

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