CODEWITHSUNDEEP
vbaexcel
D. Smith
D. Smith

Reputation: 1

First VBA code... looking for feedback to make it faster

I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet. The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.

Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?

I start with about 2500-2700 rows in each sheet I'm comparing.

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

Upvotes: 0

Views: 181

Answers (3)

Jeremy
Jeremy

Reputation: 1337

What about this (it's should help):

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

Upvotes: 0

iDevlop
iDevlop

Reputation: 25252

instead of a do...loop to find out duplicate, I would use range.find method:

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

(quickly written and untested)

Upvotes: 0

Doug Coats
Doug Coats

Reputation: 7107

This belongs in Code Review, but here is a link

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

With your code your main issues are:

Selecting/Activating Sheets

Copy & pasting.

Fix those things and youll be set straight my friend :)

Upvotes: 1

Related Questions