Question

我编写了一个宏，用于比较两个工作表中包含文件编号的列B.有三种可能性：文件编号存在于两列中，文件编号仅存在于第一列中，文件编号仅存在于第二列中。如果是两个列中都存在文件编号，宏应将整行复制/粘贴到另一个工作表。其他两个场景也是如此。

我的代码适用于小文件（大约500行，236列），但对于大文件，它不起作用。这需要太长时间，最后它只会崩溃。我已经尝试过通常的技巧来加速宏。

Option Explicit

Sub CopyPasteWorksheets()

Dim wbDec As Workbook, wbJune As Workbook, wbAnalysis As Workbook
Dim wsDec As Worksheet, wsJune As Worksheet
Dim PresPres As Worksheet, PresAbs As Worksheet, AbsPres As Worksheet

'Stop screen from updating to speed things up
Application.ScreenUpdating = False
Application.EnableEvents = False

'Add 3 new worksheets. They each represent a different category, namely the one with already existing insurances, one with new insurances
'and one with the insurances that are closed due to mortality, lapse or maturity. Add two (temporary) worksheets to paste the databases.

Worksheets.Add().Name = "PresPres"
Worksheets.Add().Name = "PresAbs"
Worksheets.Add().Name = "AbsPres"
Worksheets.Add().Name = "DataDec"
Worksheets.Add().Name = "DataJune"

'Define the active workbook

Set wbAnalysis = ThisWorkbook

'Define the first database. Copy/paste the sheet and close them afterwards.

Set wbDec = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2015\20151231\Data\DLL\Master Scala\Extract.xlsx")

wbDec.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataDec").Range("A1").PasteSpecial xlPasteValues

wbDec.Close

'We have to do the same for the other database. We cannot do it at the same time, because both files have the same name,
'and can't be opened at the same time.

Set wbJune = Workbooks.Open(Filename:="F:\Risk_Management_2\Embedded_Value\2016\20160630\Data\DLL\Master Scala\extract.xlsx")

wbJune.Sheets("SCALA").Range("A1").CurrentRegion.Copy
wbAnalysis.Sheets("DataJune").Range("A1").PasteSpecial xlPasteValues

wbJune.Close

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Sub Compare()

Dim DataDec As Worksheet, DataJune As Worksheet
Dim lastRowDec As Long
Dim lastRowJune As Long
Dim lastRowPresAbs As Long
Dim lastRowPresPres As Long
Dim lastRowAbsPres As Long
Dim foundTrue As Boolean
Dim i As Long, j As Long, k As Long, l As Long

'Define the last row of the different sheets
lastRowDec = Sheets("DataDec").Cells(Sheets("DataDec").Rows.Count, "B").End(xlUp).Row
lastRowJune = Sheets("DataJune").Cells(Sheets  ("DataJune").Rows.Count, "B").End(xlUp).Row
lastRowPresAbs = Sheets("PresAbs").Cells(Sheets("PresAbs").Rows.Count, "B").End(xlUp).Row
lastRowPresPres = Sheets("PresPres").Cells(Sheets ("PresPres").Rows.Count, "B").End(xlUp).Row
lastRowAbsPres = Sheets("AbsPres").Cells(Sheets("AbsPres").Rows.Count, "B").End(xlUp).Row

'Compare the file numbers in column B of both sheets. If they are the same, copy/paste the entire row to sheet PresPres,
'if they are not, copy/paste the entire row to sheet PresAbs.

For i = 1 To lastRowDec
foundTrue = False
For j = 1 To lastRowJune

If Sheets("DataDec").Cells(i, 1).Value = Sheets("DataJune").Cells(j, 1).Value Then
    foundTrue = True
    Sheets("PresPres").Rows(lastRowPresPres + 1) = Sheets("DataDec").Rows(i)
    lastRowPresPres = lastRowPresPres + 1
    Exit For
End If

Next j

If Not foundTrue Then
Sheets("DataDec").Rows(i).Copy Destination:= _
Sheets("PresAbs").Rows(lastRowPresAbs + 1)
lastRowPresAbs = lastRowPresAbs + 1

End If

Next i


'Look if there are file numbers that are only present in June's database. If so, copy/paste entire row to sheet AbsPres.
For k = 1 To lastRowJune
foundTrue = False
For l = 1 To lastRowDec

If Sheets("DataJune").Cells(k, 1).Value = Sheets("DataDec").Cells(l,     1).Value Then
    foundTrue = True
    Exit For
End If

Next l

If Not foundTrue Then
Sheets("DataJune").Rows(k).Copy Destination:= _
Sheets("AbsPres").Rows(lastRowAbsPres + 1)
lastRowAbsPres = lastRowAbsPres + 1

End If

Next k

'Stop screen from updating to speed things up.
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

我添加了一些评论来解释我尝试做的事情。我对VBA比较陌生，所以我相信我的编码效率不高。

有人可以看看并尝试使其有效吗？

Answer 1

基本上你正在做的是比较2列元素，你想知道什么时候：

一个元素在两列中
元素仅在第一列
元素仅在第二列

为此，您的解决方案执行：

对于第1列中的每个元素，
查找第2列中是否有此元素
如果找到了，如果没有，那么它就是两个，只是在1
继续第1列中的下一个元素
与第2列的元素完全相同

基本上，对于第1列的每个元素，您的检查列2 对于具有第2列元素的第1列

如果我们考虑n为column1的长度而m为column2的长度。这大约是2 * m * n的比较。那太多了！

我的解决方案：您正在B列中寻找数字。因此，您可以根据B列中的值对表格进行排序

然后你可以：

参考sheet1和sheet2中的当前行
将sheet1.Value（＆＃39; B＆＃39; + counter1）的值与sheet2.Value（＆＃39; B＆＃39; + counter2）进行比较
然后你有3个选择： a）这是相同的值，然后复制右侧文件中的行并递增两个计数器 b）sheet1的值越大，那么你将永远不会在sheet1中找到sheet2的值。因此，复制右侧文件中的sheet2行，只增加counter2 c）相反的
直到counter1或counter2结束为止。
由于两者可能同时不在最后，你必须复制正确文件中的剩余行，因为它们永远不会出现在＆＃34;完成的＃34;片材。

使用该解决方案，您将只阅读每个＆＃34;列＆＃34;一次！所以粗略约m + n比较:) 你赢了很多时间:)）

M = n = 90 000：

你有一个大约m * n = 8 100 000 000比较的解决方案
另一个解决方案只是大约180 000比较

Answer 2

这应该是最快的方法，因为一次复制所有数据比按行复制要快得多。

选择两列＆gt;主页标签＆gt;条件格式＆gt;突出显示单元格规则＆gt;重复值......

现在您需要importPackage(java.util.*)＆gt;的过滤器Data，但为此您需要在数字上方插入标题行。获得过滤器后，可以单击第二列过滤器并按颜色过滤。现在，您可以将可见单元格复制到复制副本的任何位置。我建议在复制之前按颜色进行排序，因为复制一个连续区域应该更快一些。

对于其他两种情况，您可以使用相同的方法，使用按颜色过滤＆gt;过滤列。没有填写。

在您录制流程的宏之前，您可以选择查看标签＆gt;宏＆gt;使用相对参考。

修改

我想我误解了这个问题。此方法需要两个列彼此相邻，因此如果它们位于单独的工作表中，您可以将它们复制并插入到A列中。您可以在应用过滤器后隐藏该列。然后，您可以根据需要删除列和标题行。

没有条件格式化的类似方法是插入一个带有辅助函数的列，该函数检查另一个表中是否存在id，但我认为它会慢一点。例如：

Filter

Answer 3

我在Excel论坛上收到了我的问题答案：

http://www.mrexcel.com/forum/excel-questions/963415-visual-basic-applications-speed-up-macro-large-file.html

感谢您的回答！

加速大文件的宏（超过90000行，236列）

3 个答案: