First, this compiled ok, but I didn't test it at all!
Option Explicit
Sub SortDossierOrder()
'
' SortDossierOrder Macro
' Sorts all akte records into 1. dossier number 2. date of akte 3. aktetype
' Order
' Deletes all records with "Doorstorting"
Dim wks As Worksheet
Dim FoundCell As Range
Set wks = ActiveSheet
With wks.Cells
'don't let excel guess at your headers.
'you know your data better than excel.
'(I used xlyes--change it if it's wrong.)
.Sort key1:=.Columns(1), order1:=xlAscending, _
key2:=.Columns(5), order2:=xlAscending, _
key3:=.Columns(3), order3:=xlAscending, _
header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
'instead of looping through each cell
'just use .find
With .Range("D
")
Do
Set FoundCell = .Cells.Find(what:="doorstotring", _
after:=.Cells(1), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
Exit Do 'done looking
Else
FoundCell.EntireRow.Delete
End If
Loop
End With
End With
End Sub
Sub DeleteExtraRows()
Dim iCtr As Long
Dim wks As Worksheet
Dim myWords As Variant
Dim FoundCell As Range
myWords = Array("retour", "geregeld")
Set wks = ActiveSheet
With wks
For iCtr = LBound(myWords) To UBound(myWords)
With .Range("D
")
Do
Set FoundCell = .Cells.Find(what:=myWords(iCtr), _
after:=.Cells(1), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
Exit Do 'done looking
Else
FoundCell.EntireRow.Delete
End If
Loop
End With
Next iCtr
End With
End Sub
Sub DeleteDuplicates()
'
' DeleteDuplicates Macro
' Macro recorded 24/10/2009 by Roger Ottaway
' Retains only the last date record for a dossier and deletes other akte for
' the dossier
Dim cLastRow As Long
Dim iRow As Long
Dim IngLastRow As Long
Dim wks As Worksheet
Dim DelRng As Range
Set wks = ActiveSheet
With wks
cLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = cLastRow To 2 Step -1
If .Cells(iRow, "B").Value = Cells(iRow - 1, "B").Value Then
If DelRng Is Nothing Then
Set DelRng = .Cells(iRow, "B")
Else
Set DelRng = Union(DelRng, .Cells(iRow, "B"))
End If
End If
Next iRow
If DelRng Is Nothing Then
'do nothing
Else
DelRng.EntireRow.Delete
End If
End With
End Sub
Sub DeleteRecentRecords()
'
' DeleteRecentRecords Macro
' Macro recorded 24/10/2009 by Roger Ottaway
' Deletes records that are less than 28 day's old
' Sorts records into akte date order (oldest to most recent)
Dim cLastRow As Long
Dim iRow As Long
Dim wks As Worksheet
Dim DelRng As Range
Set wks = ActiveSheet
With wks
cLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = cLastRow To 2 Step -1
'if you only want to use the date (not including the time)
'If .Cells(i, "E").Value > Date - 28 Then
If .Cells(iRow, "E").Value > Now - 28 Then
If DelRng Is Nothing Then
Set DelRng = .Cells(iRow, "E")
Else
Set DelRng = Union(DelRng, .Cells(iRow, "E"))
End If
End If
Next iRow
If DelRng Is Nothing Then
'do nothing
Else
DelRng.EntireRow.Delete
End If
With .Cells
'don't let excel guess at your headers.
'you know your data better than excel.
'(I used xlyes--change it if it's wrong.)
.Sort key1:=.Columns(5), order1:=xlAscending, _
header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
End Sub
Sub DeleteExtraCols()
'
' DeleteExtraCols Macro
' Macro recorded 24/10/2009 by Roger Ottaway
' Deletes two cols not needed, formats cols
Dim wks As Worksheet
Set wks = ActiveSheet
With wks
.Range("A1:b1").EntireColumn.Delete
'it looks like A
are all set the same way
'except for B and D columnwidths
With .Range("A
")
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.Range("B:B").ColumnWidth = 22.57
.Range("D
").ColumnWidth = 46.71
End With
End Sub
I'm not quite sure why "doorstotring" isn't included in the other procedure that
deletes rows based on words. It seems like a natural fit there.
Maybe you sometimes run these procedures independently????
===================
Other things that can slow your code down...
Do you see the dotted lines that you get after you do a print or print preview?
If you do
Tools|Options|view tab|uncheck display page breaks
does the run time go back to normal?
You may want to do something like:
Option Explicit
Sub testme()
Dim CalcMode As Long
Dim ViewMode As Long
Application.ScreenUpdating = False
CalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'do the work (Your code goes here)
Call SortDossierOrder
call DeleteDuplicates
Call DeleteExtraRows
Call DeleteRecentRecords
call DeleteExtraCols
'put things back to what they were
Application.Calculation = CalcMode
ActiveWindow.View = ViewMode
End Sub
Being in View|PageBreak Preview mode can slow macros down, too.
=========
If you run these procedures on their own, you may want to put that stuff in each
procedure--and remove it from the giant (do all of them at once).
