Excel VBA - Need some attention

Vader

Vader

Registered User.
Local time
Today, 13:47
Joined
Jan 18, 2007
Messages
16
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
 
Vader said:
Code: 
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
Click to expand...
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:
Code: 
    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:
Code: 
    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
Code: 
    Rows("1:12").Select 'Delete previous header rows
    Selection.Delete Shift:=xlUp
to
Code: 
    Rows("1:12").Delete Shift:=xlUp
And true for everything that works with Range().select/Selection.something
Code: 
                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
Code: 
                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...
Code: 
[B]  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True[/B]  '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
[B]    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual[/B]
Only to go on to do something you allready did...
Code: 
    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???
Code: 
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:
Code: 
With ActiveSheet.Range("A:A")
    .NumberFormat = ""
    .ColumnWidth = 9.5
    .VerticalAlignment = xlCenter
    .HorizontalAlignment = xlCenter
end with

Code: 
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 !
 
chr(160) = Non breaking space character (alt+0160)
 
Like I send you allready in the PM... I think I showed you most things up above allready...
 
Thank You!!!

Thank you very much for your time namliam;)
 
You must log in or register to reply here.

Similar threads

G
Counter help
Replies
5
Views
803
goncalo
G
B
Solved VBA code which exports data from Access to Excel and then loops through the Excel file
Replies
0
Views
725
BlueFllame
B
S
Moving Script to ThisWorkbook
Replies
1
Views
1,799
June7
June7
D
I need some help with inserting and deleting rows in a table using vba in excel
2
Replies
27
Views
4,016
Gasman
Gasman
R
Help needed to modify the following macro
Replies
1
Views
1,681
smiler44
S

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom