View Full Version : Excel VBA - Need some attention


Vader
01-18-2007, 09:37 AM
Hello to everyone who reads or is a member of this Forum!
I was only reading and searching this forum, which I must say that is one of the best, if not "THE BEST" of it`s kind, until today - I have a problem with Excel VBA code! First of all, I`m not satisfied with the speed of my code, second, I have problems running it on computers which have older versions than MS Office 2003,third, I cannot insert Page/Print setup code that meets my needs.
About the speed - The reason I`m asking this question, is to learn about speeding up VBA code. So any suggestions are welcome.
Well here is my code, so take a look!
If you need the file which goes with the code, Please let me know!!!

Sub Vader_CreateMe()
ActiveSheet.Cells.Interior.ColorIndex = xlNone 'Remove color
ActiveSheet.Cells.MergeCells = False 'Unmerge cells
ActiveSheet.Rows(13).Clear 'Clear row A13, later to be heading row for columns
Range("C:C,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T").Select 'Delete empty columns
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
Rows("1:12").Select 'Delete previous header rows
Selection.Delete Shift:=xlUp
Range("A1").Select
'Insert column names in header row
ActiveCell.Resize(, 11) = Array("[ifra", "Komintent", "Do 15 dena", "Do 30 dena", "Do 60 dena", "Do 90 dena", "Do 180 dena", "Do 360 dena", "Nad 360 dena", "Dospeani pobaruvawa", "Nedospeani pobaruvawa")
'Delete empty rows
Columns("K:K").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Delete values in column K (Nedospeani pobaruvanja),that equals 5 and under
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False
Dim lastrow As Long, r As Long
lastrow = Cells(Rows.Count, "K").End(xlUp).Row
For r = lastrow To 1 Step -1
If Cells(r, "K").Value <= 5 Then
Rows(r).EntireRow.Delete
End If
Next r
ActiveSheet.DisplayPageBreaks = True
'Remove color
ActiveSheet.Cells.Interior.ColorIndex = xlNone
'Delete cells that seem empty
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Rng As Range, ix As Long
Set Rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
For ix = Rng.Count To 1 Step -1
If Trim(Replace(Rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
Rng.Item(ix).EntireRow.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Arranges the header row
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Font.Bold = True
.Font.Name = "MAC C Swiss"
.Cells.RowHeight = 30
End With

'Remove all spaces from column A
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Selection.Range("A:A").Replace What:=Chr(160), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Selection.Range("A:A").Replace What:=Chr(32), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

'Apply header row color
Range("A1:K1").Interior.ColorIndex = 15
'Arranges columns A and B
Columns("A:B").EntireColumn.AutoFit
'Applies the number format
ActiveSheet.UsedRange.NumberFormat = "#,##0.00"
ActiveSheet.Range("A:A").NumberFormat = ""
ActiveSheet.Range("A:A").ColumnWidth = 9.5
ActiveSheet.Range("A:A").VerticalAlignment = xlCenter
ActiveSheet.Range("A:A").HorizontalAlignment = xlCenter

'Format row height and font size
ActiveSheet.UsedRange.RowHeight = 30
ActiveSheet.UsedRange.Font.Size = 12
ActiveSheet.UsedRange.VerticalAlignment = xlCenter

'Sorting of column K in descending way
Columns("A:K").Select
Selection.Sort Key1:=Range("K2"), Order1:=xlDescending
Columns("C:K").EntireColumn.AutoFit

'Insert borders within used range
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
End Sub

namliam
01-19-2007, 02:30 AM
Sub Vader_CreateMe()
ActiveSheet.Cells.Interior.ColorIndex = xlNone 'Remove color
ActiveSheet.Cells.MergeCells = False 'Unmerge cells
ActiveSheet.Rows(13).Clear 'Clear row A13, later to be heading row for columns
Range("C:C,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T").Select 'Delete empty columns
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
Rows("1:12").Select 'Delete previous header rows
Selection.Delete Shift:=xlUp
Range("A1").Select
'Insert column names in header row
ActiveCell.Resize(, 11) = Array("[ifra", "Komintent", "Do 15 dena", "Do 30 dena", "Do 60 dena", "Do 90 dena", "Do 180 dena", "Do 360 dena", "Nad 360 dena", "Dospeani pobaruvawa", "Nedospeani pobaruvawa")
'Delete empty rows
Columns("K:K").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Delete values in column K (Nedospeani pobaruvanja),that equals 5 and under
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveSheet.DisplayPageBreaks = False
Dim lastrow As Long, r As Long
lastrow = Cells(Rows.Count, "K").End(xlUp).Row
For r = lastrow To 1 Step -1
If Cells(r, "K").Value <= 5 Then
Rows(r).EntireRow.Delete
End If
Next r
ActiveSheet.DisplayPageBreaks = True
'Remove color
ActiveSheet.Cells.Interior.ColorIndex = xlNone
'Delete cells that seem empty
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Rng As Range, ix As Long
Set Rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
For ix = Rng.Count To 1 Step -1
If Trim(Replace(Rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
Rng.Item(ix).EntireRow.Delete
End If
Next
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'Arranges the header row
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Font.Bold = True
.Font.Name = "MAC C Swiss"
.Cells.RowHeight = 30
End With

'Remove all spaces from column A
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Selection.Range("A:A").Replace What:=Chr(160), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Selection.Range("A:A").Replace What:=Chr(32), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

'Apply header row color
Range("A1:K1").Interior.ColorIndex = 15
'Arranges columns A and B
Columns("A:B").EntireColumn.AutoFit
'Applies the number format
ActiveSheet.UsedRange.NumberFormat = "#,##0.00"
ActiveSheet.Range("A:A").NumberFormat = ""
ActiveSheet.Range("A:A").ColumnWidth = 9.5
ActiveSheet.Range("A:A").VerticalAlignment = xlCenter
ActiveSheet.Range("A:A").HorizontalAlignment = xlCenter

'Format row height and font size
ActiveSheet.UsedRange.RowHeight = 30
ActiveSheet.UsedRange.Font.Size = 12
ActiveSheet.UsedRange.VerticalAlignment = xlCenter

'Sorting of column K in descending way
Columns("A:K").Select
Selection.Sort Key1:=Range("K2"), Order1:=xlDescending
Columns("C:K").EntireColumn.AutoFit

'Insert borders within used range
ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
End Sub
For one thing learn to use the CODE tags! This makes reading much easier for us .... Quote my post to find out how to do it... :)

Some suggestions:
Range("C:C,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T").Select 'Delete empty columns
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
Offcourse this is recorded code... which is terribly ineffecient...
For one thing why are you not selecting all the columns??? This seems strange...
also to speed this up a little:
Range("C:C,D:D,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T").Delete Shift:=xlToLeft
Will also work.... but faster... the same is true for

Rows("1:12").Select 'Delete previous header rows
Selection.Delete Shift:=xlUp

to

Rows("1:12").Delete Shift:=xlUp

And true for everything that works with Range().select/Selection.something

For r = lastrow To 1 Step -1
If Cells(r, "K").Value <= 5 Then
Rows(r).EntireRow.Delete
End If
Next r
This can take quite a while if you have to remove quite a few rows...
2 ways to do this better/faster I think:
1) Use an (auto) filter
2) Put the rows into a variable and delete all the rows in one go

Variable = ""
For r = lastrow To 1 Step -1
If Cells(r, "K").Value <= 5 Then
Variable = variable & "," & r
End If
Next r
Rows(Mid(variable,2)).EntireRow.Delete

I havent tested it so there may be some error someplace... guess it is worth a try :)
Also you are looping thru all the rows twice... Why not do this in one go....

You are removing all colors atleast twice... As well as the screenupdating and the manual calculations (not that much time but still)

Then you are turning on automatic calculations and turning it off again (same for screen updating). This can be timeconsuming...
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'Arranges the header row
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Font.Bold = True
.Font.Name = "MAC C Swiss"
.Cells.RowHeight = 30
End With

'Remove all spaces from column A
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Only to go on to do something you allready did...
Selection.Range("A:A").Replace What:=Chr(160), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True
Selection.Range("A:A").Replace What:=Chr(32), _
Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True

You allready did this above in the loop where you replace the chr(160)...
What is chr(160) by the way???

ActiveSheet.Range("A:A").NumberFormat = ""
ActiveSheet.Range("A:A").ColumnWidth = 9.5
ActiveSheet.Range("A:A").VerticalAlignment = xlCenter
ActiveSheet.Range("A:A").HorizontalAlignment = xlCenter
If you are doing multible things like above to the same "range" it is (slightly) faster to do:

With ActiveSheet.Range("A:A")
.NumberFormat = ""
.ColumnWidth = 9.5
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
end with


Columns("A:B").EntireColumn.AutoFit
Columns("C:K").EntireColumn.AutoFit
It looks like 2 commands for the total range... There is not much time lost here but offcourse it is "Inefficient"

I am sure there is more... but .... good luck !

Vader
01-19-2007, 06:32 AM
chr(160) = Non breaking space character (alt+0160)

namliam
01-19-2007, 08:34 AM
Like I send you allready in the PM... I think I showed you most things up above allready...

Vader
01-19-2007, 10:15 AM
Thank you very much for your time namliam;)