-1
\$\begingroup\$

The macro below clears cells that do not match any cell in comparison to a range (a master list). It works on small file but is too slow to work for files with large ranges.

Sub REMOVEINV()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating =False 
Application.DisplayStatusBar =False 
Application.EnableEvents =False

Dim Rng As Range, Dn As Range 
Set Rng = Range("A2:A35524")'Range to match against

With CreateObject("scripting.dictionary") 
.CompareMode = vbTextCompare

ForEach Dn In Rng:.Item(Dn.Value)= Empty:Next

Set Rng = Range("C1:DVC62600")' Range to clear 
ForEach Dn In Rng
IfNot.exists(Dn.Value)Then Dn.ClearContents

Next Dn

EndWith

EndSub

The worksheet looks like so:

screenshot

\$\endgroup\$
  • \$\begingroup\$ Welcome to Code Review. If your code is not working correctly, it is off-topic for this site. You might try Stack Overflow if you can word the question in a way that fits the criteria on that page. Once your code works correctly, you're welcome to ask a new question here and we can then help you improve it! \$\endgroup\$ – Phrancis Jul 16 '18 at 18:37
  • \$\begingroup\$ I did just come from overflow. As stated in the post it does work correctly on normal files; on super large files however it is not efficient enough to work so needs to be improved; I do not know how to write loops though. I'm sorry if I wasn't clear \$\endgroup\$ – Tardisgx Jul 16 '18 at 18:40
1
\$\begingroup\$

Okay, so good job giving both declared variables a type, a lot of people forget that!

But, your naming is sort of weak and doesn't follow Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names.

I know it's just a small script, but since you're using it on more than one sheet, apparently, you should make it more robust.

Always turn on Option Explicit. You can have it automatically by going to Tools -> Options in the VBE and checking the Require Variable Declaration option. This way if you have any variables not defined, the compiler will let you know.

You have a With and create an object. Instead perhaps create the object and then use it:

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

It's good practice to indent all of your code that way Labels will stick out as obvious. Right now it's all flat and it's not obvious your first loop has a Next.

So I'll assume you want to stick with a dictionary.

Dim lastRow As Long
lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Dim dictRange As Range
Set dictRange = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(lastRow, 1))

Dim dict As Object
dict = CreateDictionary(dictRange)

Private Function CreateDictionary(ByVal dictRange As Range) As Object
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim keyRange As Range
    For Each keyRange In dictRange
        dict.Item(keyRange.Value) = 1
    Next
    CreateDictionary = dict
End Function

Here you pass the range you need to a helper function and create the dictionary. Now you want to check if certain cells' values are keys of the dictionary. It's not clear how you determine this because you're using an enormous range, for some reason. Let's assume you just want Column C-

lastRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
    If Not dict.exists(Sheet1.Cells(i, 3).Value) Then Sheet1.Range(Sheet1.Cells(i, 3), Sheet1.Cells(i, 200)).Clear
Next

Done, yeah?

So the reason you're hanging is because you're iterating through enormous ranges that are probably mostly blank. You need to be explicit in your ranges. You're also dealing with the data on the sheet, which is slow - Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

You also turn a bunch of stuff off, but don't turn it back on!

Public Sub RemoveNonDuplicates()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    Dim lastRow As Long
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Dim dictRange As Range
    Set dictRange = Sheet1.Range(Sheet1.Cells(1, 1), Sheet1.Cells(lastRow, 1))

    Dim dict As Object
    dict = CreateDictionary(dictRange)

    lastRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
    Dim i As Long
    For i = 1 To lastRow
        If Not dict.exists(Sheet1.Cells(i, 3).Value) Then Sheet1.Range(Sheet1.Cells(i, 3), Sheet1.Cells(i, 200)).Clear
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
End Sub

Private Function CreateDictionary(ByVal dictRange As Range) As Object
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim keyRange As Range
    For Each keyRange In dictRange
        dict.Item(keyRange.Value) = 1
    Next
    CreateDictionary = dict
End Function
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.