第一个VBA代码…寻找反馈，使其更快

我写了一个小的VBAmacros来比较两个工作表，并将唯一值放到新的第三个工作表中。 代码的作品，但每次我使用，如果Excel的“不响应”，并在30-45秒后回来，一切工作，因为它应该。

我可以做得更快，摆脱“没有回应”的问题吗？ 这只是我的电脑不够快？

我从每张表中大约2500-2700行开始比较。

Sub FilterNew() Dim LastRow, x As Long Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet Sheets(1).Select LastRow = Range("B1").End(xlDown).Row Application.ScreenUpdating = False For Each Cell In Range("B2:B" & LastRow) x = 2 'This is for looking through rows of sheet2 Dim unique As Boolean: unique = True Do If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2 unique = False 'If the cells match, then its not unique Exit Do 'And no need to continue testing End If x = x + 1 Loop Until IsEmpty(Sheets(2).Cells(x, "B")) If unique = True Then Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) End If Next Application.ScreenUpdating = True End Sub 

Answer 1

这属于代码审查，但这是一个链接

http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html

用你的代码你的主要问题是：

select/激活表格

复制和粘贴。

修复这些东西，你会被设置我的朋友直:)

Answer 2

而不是一个do...loop找出重复，我会使用range.find方法：

 set r = SHeets(2).range("b:b").find cell.value if r is nothing then unique = true else unique = false 

（快速写入和未经testing）

Answer 3

这怎么样（这应该有所帮助）：

 Sub FilterNew() Dim Cel, Rng As Range Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row) For Each Cel In Rng If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you? Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub