PDA

View Full Version : Help with code cleanup.



had1015
04-04-2008, 03:06 PM
Using Excel 2003. This is my first post although I view and get others' knowledge sometimes. I am tring to work on cleaning my code. Please help.
Thanks..


Sub Update()
Dim LFile As String
Application.ScreenUpdating = False
Dim Pth As String
Pth = "C:\CURRENT\"
LFile = LatestFile(Pth)
Workbooks.Open Pth & LFile
Range("A1:H1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ThisWorkbook.Activate
Range("K1").Select
ActiveSheet.Paste
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NEWEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R2C2:R71C2"
Range("L29").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="OLDEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R29C12:R71C12"
Range("I29").Select
Range("A1:H1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("K1:R1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("P2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("I2").Select
ActiveSheet.Paste
Columns("J:J").Select
Application.CutCopyMode = False
Range("J2").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"
Columns("J:J").Select
Selection.NumberFormat = "General"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J71"), Type:=xlFillDefault
Range("J2:J71").Select
Range("J59").Select
Columns("I:I").Select
Selection.EntireColumn.Hidden = True
Columns("K:R").Select
Selection.Delete Shift:=xlToLeft
Range("L9").Select
Cells.Select
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("G43").Select
Range("D2").Select
Range("J1").Select
ActiveCell.FormulaR1C1 = "DIFF FROM LAST WEEK"
Range("J1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("K10").Select
End Sub

Function LatestFile(Pth As String)
Dim fdate, tmp, fname As String, LastFile As String
tmp = 0
fname = Dir(Pth & "EVENT ANALYSIS REPORT" & strdate & "*.xls")

Do
On Error Resume Next
fdate = Split(fname, "of ")(1)
fdate = CDate(Split(fdate, ".")(0))
If fdate > tmp Then
tmp = fdate
LastFile = fname
End If
fname = Dir
Loop Until fname = ""
LatestFile = LastFile
End Function

Simon Lloyd
04-04-2008, 03:33 PM
You do an awful lot of selecting, you don't need to select in order to manipulate an object, that said i haven't seen your workbook so this is the best i can do at cleaning it up without further knowledge!

Sub Update()
Dim LFile As String
Dim rRange As Range
Application.ScreenUpdating = False
Dim Pth As String
Set rRange = Range("A1:H" & Range("H65536").End(xlUp).Row)
Pth = "C:\CURRENT\"
LFile = LatestFile(Pth)
Workbooks.Open Pth & LFile
rRange.Copy Destination:=Range("K1")
ActiveWorkbook.Names.Add Name:="NEWEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R2C2:R71C2"
Range("L29").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Names.Add Name:="OLDEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R29C12:R71C12"
rRange.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("K1:R1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("P2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy Destination:=Range("I2")
Columns("J:J").Select
Selection.NumberFormat = "General"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"
Selection.AutoFill Destination:=Range("J2:J71"), Type:=xlFillDefault
Columns("I:I").EntireColumn.Hidden = True
Columns("K:R").Delete Shift:=xlToLeft
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("J1").Select
ActiveCell.FormulaR1C1 = "DIFF FROM LAST WEEK"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("K10").Select
End Sub
Function LatestFile(Pth As String)
Dim fdate, tmp, fname As String, LastFile As String
tmp = 0
fname = Dir(Pth & "EVENT ANALYSIS REPORT" & strdate & "*.xls")
Do
On Error Resume Next
fdate = Split(fname, "of ")(1)
fdate = CDate(Split(fdate, ".")(0))
If fdate > tmp Then
tmp = fdate
LastFile = fname
End If
fname = Dir
Loop Until fname = ""
LatestFile = LastFile
End Function

when posting code, when you have pasted it highlight it and click the green VBA square at the top of your post window!

mdmackillop
04-04-2008, 03:46 PM
Try

Sub Update()
Dim LFile As String
Dim Rng As Range

Const Pth = "C:\CURRENT\"
Application.ScreenUpdating = False

Workbooks.Open (Pth & LatestFile(Pth))

Set Rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Resize(, 8)
Rng.Copy Range("K1")

With ActiveWorkbook.Names
.Add Name:="NEWEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R2C2:R71C2"
.Add Name:="OLDEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R29C12:R71C12"
End With

Rng.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Rng.Offset(, 8).Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Set Rng = Range(Cells(1, 16), Cells(1, 16).End(xlDown))
Rng.Copy Range("I2")

Range("J2").FormulaR1C1 = "=RC[-4]-RC[-1]"
Columns("J:J").NumberFormat = "General"
Range("J2").AutoFill Destination:=Range("J2:J71"), Type:=xlFillDefault
Columns(9).Hidden = True
Columns("K:R").Delete

Set Rng = Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Resize(, 10)
Rng.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
With Range("J1")
.Formula = "DIFF FROM LAST WEEK"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub

had1015
04-05-2008, 05:15 AM
Thank you both for your input. With your changes I was able to tweak and it was a major improvement. One thing I should have mentione was that I was working in an existing workbook prior to opening the one located in path. It now works great. You guys are the greatest. This is my final version.


Sub Update()
Dim LFile As String
Dim Rng As Range

Const Pth = "C:\CURRENT\"
Application.ScreenUpdating = False

Workbooks.Open (Pth & LatestFile(Pth))

Set Rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Resize(, 8)

ThisWorkbook.Activate

Rng.Copy Range("K1")

With ActiveWorkbook.Names
.Add Name:="NEWEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R2C2:R71C2"
.Add Name:="OLDEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R29C12:R71C12"
End With

Range("A1:H1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Range("K1:R1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Set Rng = Range(Cells(2, 16), Cells(2, 16).End(xlDown))
Rng.Copy Range("I2")

Range("J2").FormulaR1C1 = "=RC[-4]-RC[-1]"
Columns("J:J").NumberFormat = "General"
Range("J2").AutoFill Destination:=Range("J2:J71"), Type:=xlFillDefault
Columns(9).Hidden = True
Columns("K:R").Delete

Set Rng = Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Resize(, 10)
Rng.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
With Range("J1")
.Formula = "DIFF FROM LAST WEEK"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = 15
End With
With Range("I1")
.Formula = "LAST WEEK'S DATES"
.WrapText = True
.Interior.ColorIndex = 15
End With
Columns("J:J").ColumnWidth = 8
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter
Range("J1").Select
End Sub

Edited by Simon Lloyd for wrapping code

mdmackillop
04-05-2008, 06:03 AM
You can tidy up and simplify your coding using a function to create the RangeDown ranges, especially with repeated usage as in your code.

BTW, when yopu post code, select it and click the VBA button to format it as shown.


Sub Update()
Dim LFile As String
Dim Rng As Range
Const Pth = "C:\CURRENT\"

Application.ScreenUpdating = False

Workbooks.Open (Pth & LatestFile(Pth))
Set Rng = Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Resize(, 8)
ThisWorkbook.Activate
Rng.Copy Range("K1")

With ActiveWorkbook.Names
.Add Name:="NEWEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R2C2:R71C2"
.Add Name:="OLDEVT", RefersToR1C1:= _
"='EVENT ANALYSIS'!R29C12:R71C12"
End With

eRng("A1:H1").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

eRng("K1:R1").Sort Key1:=Range("L2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

eRng("P2").Copy Range("I2")

Range("J2").FormulaR1C1 = "=RC[-4]-RC[-1]"
Columns("J:J").NumberFormat = "General"
Range("J2").AutoFill Destination:=Range("J2:J71"), Type:=xlFillDefault
Columns(9).Hidden = True
Columns("K:R").Delete

eRng("A2").Resize(, 10).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

With Range("J1")
.Formula = "DIFF FROM LAST WEEK"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Interior.ColorIndex = 15
End With

With Range("I1")
.Formula = "LAST WEEK'S DATES"
.WrapText = True
.Interior.ColorIndex = 15
End With

Columns("J:J").ColumnWidth = 8
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter
Range("J1").Select

End Sub

Function eRng(Rng As String) As Range
Set eRng = Range(Range(Rng), Range(Rng).End(xlDown))
End Function

Simon Lloyd
04-05-2008, 07:07 AM
Why do you turn AutoFilters on and then immediately off here?
Range("A1").Select
Selection.AutoFilter
Selection.AutoFilter
Range("J1").Selectit would be better like this if you do not want to turn it off again:

Range("A1").AutoFilter
Range("J1").Select
or if you just want to turn autofilters off then:

ActiveSheet.AutoFilterMode = False
Range("J1").Select
You also copy Range("I2") but then do nothing with it, it's a waste of memory.