speeding up Macro

[jwilson28]

Hi all,

I would really appreciate any help

I have been able to find and modify a macro to do what I need, however it takes so long that it would would be quicker to do what I want it to do manually.

I have up to 40 input values from A1:A40 which are from a barcode scanner in a worksheet called 'Module Movements'. I then need to compare these values to cells A1:A1000 in worksheet 'Sheet2' and delete any values that match the values in 'Module Movements'

It is currently taking 4min 22seconds to complete this task.



Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer



iListCount = Sheets("sheet2").Range("A1:A1000").Rows.Count
For Each x In Sheets("Module Movements").Range("A1:A40")
For iCtr = 1 To iListCount
If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
Sheets("Sheet2").Cells(iCtr, 1).ClearContents
iCtr = iCtr + 1
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Thanks

Jon

 

[Fluff]

How about

Sub DeleteDupes()
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sheets("Module Movements").Range("A1:A40")
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Cl In Sheets("Sheet2").Range("A1:A1000")
         If .exists(Cl.Value) Then Cl.ClearContents
      Next Cl
   End With
End Sub

 

[Rick Rothstein]

Does this macro do what you want...

[table="width: 500"]
[tr]
	[td]Sub DelDups_TwoLists()
  Dim Cell As Range
  For Each Cell In Sheets("Module Movements").Range("A1:A40").SpecialCells(xlConstants)
     Sheets("Sheet2").Columns("A").Replace Cell.Value, "", xlWhole, , False, , False, False
  Next
End Sub[/td]
[/tr]
[/table]

 

[jwilson28]

Does this macro do what you want...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub DelDups_TwoLists()
  Dim Cell As Range
  For Each Cell In Sheets("Module Movements").Range("A1:A40").SpecialCells(xlConstants)
     Sheets("Sheet2").Columns("A").Replace Cell.Value, "", xlWhole, , False, , False, False
  Next
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

Thanks both, they are both considerably quicker than what I was using before.

 

[Fluff]

Glad we could help & thanks for the feedback

 

[jwilson28]

Hi Fluff

Is there any way of using some of the same code to match the cells values in column I of the 'Module Movement' sheet to column B of 'Sheet2' and when there is a match to put what is in column G in 'Module Movements' into column A of Module movements?

For example if I1 in 'Module Movements' was the same as B2 in 'Sheet 2' it would put the value of G1 in 'Module Movements' into A1 of 'Sheet2'?

I have been trying to find something online to try and re-purpose but I'm struggling.

Thanks

 

[Fluff]

yes that can be done, but youl'd be overwriting the existing values in Sheet2, col A. Is that correct?
Also if the value was found in B2 sheet2, do you want the col G value to goto A1 or A2?

 

[jwilson28]

yes that can be done, but youl'd be overwriting the existing values in Sheet2, col A. Is that correct?
Also if the value was found in B2 sheet2, do you want the col G value to goto A1 or A2?

Hopefully if everything leading up to this point works correctly, there shouldn't be anything in col A but if there is yes, it would need to be overwritten.

If the value is found in B2 sheet2 I would like the value to go into the corresponding cell in Column A, so A2.

I hope this makes sense.

 

[Fluff]

How about

Sub DeleteDupes()
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sheets("Module Movements").Range("A1:A40")
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Cl In Sheets("Sheet2").Range("A1:A1000")
         If .exists(Cl.Value) Then Cl.ClearContents
      Next Cl
      .RemoveAll
      For Each Cl In Sheets("Module Movements").Range("I1:I40")
         .Item(Cl.Value) = Cl.Offset(, -2).Value
      Next Cl
      For Each Cl In Sheets("Sheet2").Range("B1:B1000")
         If .exists(Cl.Value) Then Cl.Offset(, -1).Value = .Item(Cl.Value)
      Next Cl
   End With
End Sub

 

[Rick Rothstein]

How about

Sub DeleteDupes()
   Dim Cl As Range
   
   With CreateObject("scripting.dictionary")
[B][COLOR="#FF0000"]      For Each Cl In Sheets("Module Movements").Range("A1:A40")
         .Item(Cl.Value) = Empty
      Next Cl
      For Each Cl In Sheets("Sheet2").Range("A1:A1000")
         If .exists(Cl.Value) Then Cl.ClearContents
      Next Cl
      .RemoveAll
[/COLOR][/B]      For Each Cl In Sheets("Module Movements").Range("I1:I40")
         .Item(Cl.Value) = Cl.Offset(, -2).Value
      Next Cl
      For Each Cl In Sheets("Sheet2").Range("B1:B1000")
         If .exists(Cl.Value) Then Cl.Offset(, -1).Value = .Item(Cl.Value)
      Next Cl
   End With
End Sub

Fluff... am I missing something? Why do you need the lines of code I highlighted in red for a dictionary that was just created "on the fly"?