我在提供VBA代码时遇到了一些问题，并希望得到任何帮助。
我有两个工作簿（1）是我收到的月度报告，其中包含多个工作表，工作表＆＃34; host_scan_data ＆＃34;包含我需要使用的信息的来源。另一个工作簿（2）是我将存储所有合并日期月份的地方。
我是如何尝试完成此任务的： 1.启动工作簿＃2 2.单击分配了以下VBA代码的按钮（见下文） 3.浏览并选择我的月度报告（工作簿＃1） 4.在工作簿＃2中指定工作表选项卡，我希望存储此合并信息 5.提示用户验证将存储数据的工作表选项卡
根据上述回复，宏将分析＆＃34; host_scan_data ＆＃34;中的列K 。工作簿（1）的工作表，我希望它删除列k 包含＆＃34; 0＆＃34; （注意我唯一关心的值是4,3,2,1）。一旦该操作完成，我希望宏将整合的条目列表复制到上面步骤＃4中指定的位置。
我已尝试使用一些代码变体，其他解决方案似乎在＆＃34; host_scan_data ＆＃34;工作表包含＆lt; 4,000行但是一旦我超过该数量（给予或接受），excel就会变得没有响应。理想情况下，此解决方案需要处理大约150,000多行。
以下是我目前使用的代码，当我执行时错误输出＆＃34; .Sort .Columns（cl + 1），标题：= xlYes＆＃34;：
到目前为止我的守则：
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
答案 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