Consulting

Results 1 to 6 of 6

Thread: Help with code cleanup.

  1. #1
    VBAX Regular
    Joined
    Sep 2007
    Location
    Virginia
    Posts
    49
    Location

    Help with code cleanup.

    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..

    [VBA]
    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
    [/VBA]

  2. #2
    Moderator VBAX Guru Simon Lloyd's Avatar
    Joined
    Sep 2005
    Location
    UK
    Posts
    3,003
    Location
    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!
    [vba]
    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

    [/vba]when posting code, when you have pasted it highlight it and click the green VBA square at the top of your post window!
    Regards,
    Simon
    Please read this before cross posting!
    In the unlikely event you didn't get your answer here try Microsoft Office Discussion @ The Code Cage
    If I have seen further it is by standing on the shoulders of giants.
    Isaac Newton, Letter to Robert Hooke, February 5, 1675 English mathematician & physicist (1642 - 1727)

  3. #3
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    Try
    [VBA]
    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
    [/VBA]
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  4. #4
    VBAX Regular
    Joined
    Sep 2007
    Location
    Virginia
    Posts
    49
    Location
    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.

    [VBA]
    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
    [/VBA]
    Edited by Simon Lloyd for wrapping code

  5. #5
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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.

    [vba]
    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

    [/vba]
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  6. #6
    Moderator VBAX Guru Simon Lloyd's Avatar
    Joined
    Sep 2005
    Location
    UK
    Posts
    3,003
    Location
    Why do you turn AutoFilters on and then immediately off here?
    [vba]Range("A1").Select
    Selection.AutoFilter
    Selection.AutoFilter
    Range("J1").Select[/vba]it would be better like this if you do not want to turn it off again:
    [vba]
    Range("A1").AutoFilter
    Range("J1").Select
    [/vba]or if you just want to turn autofilters off then:
    [vba]
    ActiveSheet.AutoFilterMode = False
    Range("J1").Select
    [/vba]You also copy Range("I2") but then do nothing with it, it's a waste of memory.
    Regards,
    Simon
    Please read this before cross posting!
    In the unlikely event you didn't get your answer here try Microsoft Office Discussion @ The Code Cage
    If I have seen further it is by standing on the shoulders of giants.
    Isaac Newton, Letter to Robert Hooke, February 5, 1675 English mathematician & physicist (1642 - 1727)

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •