Go Back   Access World Forums > Apps and Windows > Excel

 
Reply
 
Thread Tools Rate Thread Display Modes
Old 01-18-2007, 09:37 AM   #1
Vader
Registered User
 
Vader's Avatar
 
Join Date: Jan 2007
Location: Macedonia
Posts: 16
Thanks: 0
Thanked 0 Times in 0 Posts
Vader is on a distinguished road
Excel VBA - Need some attention

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,F:F,H:H,J:J,L:L,N:N,P:P,R:R,T:T").S elect '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).Enti reRow.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 is offline   Reply With Quote
Old 01-19-2007, 02:30 AM   #2
namliam
The Mailman - AWF VIP
 
Join Date: Aug 2003
Location: Amsterdam/The Netherlands
Posts: 11,395
Thanks: 0
Thanked 800 Times in 787 Posts
namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light
Quote:
Originally Posted by Vader
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
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:
  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...
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 !
namliam is offline   Reply With Quote
Old 01-19-2007, 06:32 AM   #3
Vader
Registered User
 
Vader's Avatar
 
Join Date: Jan 2007
Location: Macedonia
Posts: 16
Thanks: 0
Thanked 0 Times in 0 Posts
Vader is on a distinguished road
chr(160) = Non breaking space character (alt+0160)

Vader is offline   Reply With Quote
Old 01-19-2007, 08:34 AM   #4
namliam
The Mailman - AWF VIP
 
Join Date: Aug 2003
Location: Amsterdam/The Netherlands
Posts: 11,395
Thanks: 0
Thanked 800 Times in 787 Posts
namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light namliam is a glorious beacon of light
Like I send you allready in the PM... I think I showed you most things up above allready...
namliam is offline   Reply With Quote
Old 01-19-2007, 10:15 AM   #5
Vader
Registered User
 
Vader's Avatar
 
Join Date: Jan 2007
Location: Macedonia
Posts: 16
Thanks: 0
Thanked 0 Times in 0 Posts
Vader is on a distinguished road
Thumbs up Thank You!!!

Thank you very much for your time namliam

Vader is offline   Reply With Quote
Reply

Thread Tools
Display Modes Rate This Thread
Rate This Thread:

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Pagebreak in Excel from VBA Access tdubs Modules & VBA 1 06-21-2013 10:48 AM
Desperate for Help - VBA output to Excel Trouble Waabs Modules & VBA 7 10-13-2005 12:38 AM
[SOLVED] Seems like VBA cannot handle two excel files true.silenoz Modules & VBA 2 09-01-2003 06:14 PM
Close Excel through VBA DrQuality Modules & VBA 1 07-17-2002 05:51 AM
HELP! Running VBA Procedures from EXcel benjy5 Modules & VBA 0 07-16-2002 03:52 PM




All times are GMT -8. The time now is 12:12 AM.


Microsoft Access Help
General
Tables
Queries
Forms
Reports
Macros
Modules & VBA
Theory & Practice
Access FAQs
Code Repository
Sample Databases
Video Tutorials

Featured Forum post


Sponsored Links


Powered by vBulletin®
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
(c) copyright 2017 Access World