slow code

  • Thread starter Thread starter jocke
  • Start date Start date
J

jocke

i've made a code that searches one optional column for duplicates and
deletes 2-6 cells in the same row as a duplicate data is found.
I'm using this code a lot and my problem is that it can take very long
time for the code to run, it can take 1 hour or more if i'm searching
like 15000 rows.

I'm going to the last cell in my row and uses the countif command to
determine if there are duplicates, if not then i go to the cell above
and run an new countif.

is there a faster way to do this?

jocke
 
Post your code...it will make it easier to help you since you
weren't very specific about which cells to look at, whether you
delete both duplicates or only one, etc...

Please paste it into a reply to this message - don't attach a file!
 
ok here's the code with some additional comments



Sub startsortering()
Dim rngDub As Range ' dublettrad
Dim UserRange As Range
Dim rng As Range ' dataområde
Dim intCol As Variant ' dublettkolumn
Dim lngRadAntal As Long
Dim VarValue As Variant ' jämförelsevärde
Dim RadDub As Range
Dim svar As Integer
Dim TopRow As Long
Dim BottomRow As Long
Dim område As Range
Dim TopCell As Variant
Dim BottomCell As Variant
Dim Kolumner As Range
On Error GoTo hell

start: '(selecting columns to compare and columns to delete)
Set rngDub = Application.InputBox("markera kolumn med dubletter",
"Radera dubletter", Type:=8)
rngDub.Select
If rngDub.Cells.Count <> 1 Then
MsgBox ("Du får bara välja 1 cell, välj igen ")
GoTo start
End If
lkol = ActiveCell.Column
hkol = ActiveCell.Column
svar = MsgBox(" skall data raderas i flera kolumner? ", vbYesNo +
vbQuestion, "Radera dubletter")
If svar = 6 Then
Set Kolumner = Application.InputBox("markera kolumner du vill
radera i ", "Radera dubletter", Type:=8)
lkol = 1
For Each Cell In Kolumner
If Cell.Column <= lkol Then lkol = Cell.Column
hkol = Cell.Column
Next Cell
End If
'*********************************************************************************
' kontrollerar dataområde (selecting range with duplicates)
Application.ScreenUpdating = False
intCol = ActiveCell.Column
If ActiveCell.Offset(1, 0).Value = "" Then Set BottomCell = ActiveCell
Else Set BottomCell = ActiveCell.End(xlDown)
If ActiveCell.Row = 1 Then
Set TopCell = ActiveCell
GoTo Nästa
End If
If ActiveCell.Offset(-1, 0).Value = "" Then Set TopCell = ActiveCell
Else Set TopCell = ActiveCell.End(xlUp)
Nästa:
Set område = Range(TopCell, BottomCell)
BottomRow = BottomCell.Row
TopRow = TopCell.Row

'***************************************************************************************************


'********************************************************************************
'letar dubletter (search for duplicates)
For lngRadAntal = BottomRow To TopRow Step -1
VarValue = Cells(lngRadAntal, intCol).Value
If Application.WorksheetFunction.CountIf(område, VarValue) > 1 Then
For kol = hkol To lkol Step -1
Cells(lngRadAntal, kol).Delete shift:=xlUp
Next kol
End If
Next lngRadAntal
hell:
Application.ScreenUpdating = True

End Sub
 
One way to make code run faster is to turn off screen refreshing while
the code works
type "Application.ScreenUpdating = False" at the beginning of the Macro
and "Application.ScreenUpdating = True" at the end
Good luck
Moshe
 
Along with Moshe's suggestion of turning off screenupdating, you could toggle
the calculation mode to manual, run your macro and then toggle calculation mode
back to what it was before (automatic???).

Another thing that will slow down your macro when you're deleting/inserting rows
and columns is having those dotted pagebreaks lines showing?

Excel will try to figure out where it should draw these lines each time you do a
delete/add.

You could add something like this to the top of your code:
ActiveSheet.DisplayPageBreaks = False
 
Back
Top