Can you help me speed up this posted code?

[Grizlore]

Although this code works great, it takes an age (+50mins) to run.

Could anyone have a look and see if this code can be speeded up anywhere please?

Any help would be appreciated

Sub Button()

Application.ScreenUpdating = False

Dim TheFolder As String
Dim TheFile As String
Dim TheHyperlinkPath As String
Dim TheRow As Integer
Dim CreationDate As Date

TheRow = 2

TheFolder = "\\WWW0\WWWSHARE\GMP\Quality and Hygiene\CofAs"

TheFile = Dir(TheFolder & "\*.*")

Sheets("All the CofAs").Select

    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    Range("A2").Select


Do Until TheFile = ""

            TheHyperlinkPath = TheFolder & "\" & TheFile
            Sheets("All the CofAs").Cells(TheRow, 1).Select
            Sheets("All the CofAs").Hyperlinks.Add Anchor:=Cells(TheRow, 1), Address:= _
            TheHyperlinkPath, TextToDisplay:=TheFile
            ActiveCell.Offset(0, 1).Activate
            ActiveCell = FileDateTime(TheHyperlinkPath)
            TheRow = TheRow + 1
            TheFile = Dir

Loop

    With Sheets("All the CofAs")

        With .Columns("A")
        .AutoFilter Field:=1, Criteria1:="Certificates Of Analysis.xls"
        On Error Resume Next
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
                On Error GoTo 0
        End With


    End With

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Certificate of Analysis File Name"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "File Date"
    Rows("1:1").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With

        Range("B2").Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


        Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=".", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "File Type"
    Range("C9").Select
    Columns("B:C").EntireColumn.AutoFit

      Columns("B:C").Select
    Selection.Font.Underline = xlUnderlineStyleSingle
    Selection.Font.Underline = xlUnderlineStyleNone
    Selection.Font.ColorIndex = 1
    Columns("B:C").EntireColumn.AutoFit
    Selection.ColumnWidth = 12.5
    Columns("C:C").Select
    Columns("C:C").EntireColumn.AutoFit
    Columns("B:B").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("C:C").Select
    Selection.ColumnWidth = 17.71
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1").Select
    Selection.AutoFilter
    
    MsgBox "All CofAs have now been imported"
   
   Application.ScreenUpdating = True
    
End Sub

Thanks for looking

 

[snowblizz]

I think we'll have to send you back to do your homework first.

This:

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Certificate of Analysis File Name"

should really be like this:

    Rows("1:1").Insert Shift:=xlDown
    Range("A1").FormulaR1C1 = "Certificate of Analysis File Name"

and the same goes for largely ALL the ".select Selection." pairs
fix that and we can look further, I think you are eg reformatting the columns B and C multiple times.

Also when you clearcontents, could you just not simply clear ALL contents in one go instead of finding the filled range? Or is there something you want to save before making the new links?

 

[Grizlore]

Thanks... I'll tidy up those ".selects"

What I basically want to do is...

Catalogue the stated folder, into one worksheet... with columns for "File Name" (which is a hyperlink to the file) and the "File Date". There is also a column for "file type" but that is just needed to create the proper hyperlink address.

The clearing of the sheet needs only to be done once, if/when the code is started

 

[snowblizz]

When you've tidied up those selects put the code back up and we'll have another look at it. There was just SO many selects I would have to remove it was looking like a bother. Also removing the selects should speed up the code.

This block:

Sheets("All the CofAs").Select

    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.ClearContents
    Range("A2").Select

can probably be replaced with this (provided you just want to clear everything existing in the worksheet):

Worksheets("All the CofAs").usedrange.clearcontents

 

[Grizlore]

Now that's slimmed it down somewhat

Sub Button()

Application.ScreenUpdating = False

Dim TheFolder As String
Dim TheFile As String
Dim TheHyperlinkPath As String
Dim TheRow As Integer
Dim CreationDate As Date

TheRow = 1

TheFolder = "\\Wbx0\WBXSHARE\GMP\Quality and Hygiene\CofAs"
TheFile = Dir(TheFolder & "\*.*")

Worksheets("All the CofAs").UsedRange.ClearContents

Do Until TheFile = ""

            TheHyperlinkPath = TheFolder & "\" & TheFile
            Sheets("All the CofAs").Select ' doesnt work without this line in
            Sheets("All the CofAs").Cells(TheRow, 1).Select
            Sheets("All the CofAs").Hyperlinks.Add Anchor:=Cells(TheRow, 1), Address:= _
            TheHyperlinkPath, TextToDisplay:=TheFile
            TheRow = TheRow + 1
            TheFile = Dir
Loop

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Certificate of Analysis File Name"

    Rows("1:1").Select
    Selection.Font.Bold = True

    Columns("A:C").EntireColumn.AutoFit
      Range("B1").Select
    MsgBox "All CofAs have now been imported"
   
   Application.ScreenUpdating = True
    
End Sub

 

[snowblizz]

I think you can trim it down further to this. But after that I think we are running out of things to do.

I see you've cut out a lot of code, was it unnecessary or you just didn't want to swamp us in code?
Hopefully you haven't cut out too much of what you needed done.

Sub Button()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim TheFolder As String
Dim TheFile As String
Dim TheHyperlinkPath As String
Dim TheRow As Integer
Dim CreationDate As Date

TheRow = 1

TheFolder = "\\Wbx0\WBXSHARE\GMP\Quality and Hygiene\CofAs"
TheFile = Dir(TheFolder & "\*.*")

Worksheets("All the CofAs").UsedRange.ClearContents

Do Until TheFile = ""

            TheHyperlinkPath = TheFolder & "\" & TheFile
            Sheets("All the CofAs").Select ' doesnt work without this line in
            Sheets("All the CofAs").Hyperlinks.Add Anchor:=Cells(TheRow, 1), Address:= _
            TheHyperlinkPath, TextToDisplay:=TheFile
            TheRow = TheRow + 1
            TheFile = Dir
Loop

    Rows("1:1").Insert Shift:=xlDown
    Range("A1").FormulaR1C1 = "Certificate of Analysis File Name"

    Rows("1:1").Font.Bold = True

    Columns("A:C").EntireColumn.AutoFit
      Range("B1").Select
    MsgBox "All CofAs have now been imported"

   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
    
End Sub

 

[Grizlore]

Thanks for your help. The code is much quicker.

I have cut out code which wasnt needed... however, saying that.. the speeding up of the code has produced another problem... I have posted that here

--> http://www.mrexcel.com/forum/showthread.php?p=2331253#post2331253


Thanks again for your time and help