Speed up code for loops and hyperlinks

[Firesword]

Hi All

I've got some code (Below) that will loop line by line through a worksheet, and generate a hyperlink using the information on each line. My code does work but there are 800,000 lines and to do this line by line takes too long, and I could do with running this file once or twice a day. Is there a way to this onmass rather than line by line. I've put comments on the code explaining the lines and I hope this makes sense.

Thanks

Simon

Sub HyperPOs()

Dim strDirNewName, strDirOldName As String
Dim ch, strOpenPOEndRow  As Long

        'Will look at a SQL table and count how many lines - used for the loop
        strOpenPOEndRow = [Table_Open_PO[#ALL]].Rows.Count

        'Because the SQL table updates automatically I need to delete the current hyperlinks in columns F (and there maybe new hyperlinks added in columns A to D later)
        Sheets(Sheet8.Name).Range("A:F").Hyperlinks.Delete

        'When the hyperlinks are deleted sometimes you still get the underline on the cell, next lines just copies and pastes formats over the hyper link columns and then autofit the columns
        Sheets(Sheet8.Name).Columns("E:E").Copy
        Sheets(Sheet8.Name).Columns("F:F").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Sheets(Sheet8.Name).Columns("F:F").EntireColumn.AutoFit

        'ch is the starting row and used to check the loop
        ch = 2

        Do While ch <= strOpenPOEndRow

            'Due to a company change of name there could be two names used which is why I need both lines
            'The information to generate the hyperlinks are in columns B, and F, I don't use the tab names as my users keep changing them so use the sheet8.name instead, with ch as the line number
            strDirNewName = "\\xxx.xxx.xxx.xx\Sage\Archive\PO Archive\" & Sheets(Sheet8.Name).Range("B" & ch).Value & "\" & "NewName Purchase Order " & Sheets(Sheet8.Name).Range("F" & ch).Value & ".pdf"
            strDirOldName = "\\xxx.xxx.xxx.xx\Sage\Archive\PO Archive\" & Sheets(Sheet8.Name).Range("B" & ch).Value & "\" & "OldName Purchase Order " & Sheets(Sheet8.Name).Range("F" & ch).Value & ".pdf"

            'Next bit of code there are 3 options
            '1 PO exists with the new name - generate hyperlink
            '2 PO exists with the old name - generate hyperlink
            '3 PO does not exists - In column AQ state "PO is missing" - This is an audit failure and needs to be addressed
            If Dir(strDirNewName) <> "" Then
                Sheets(Sheet8.Name).Hyperlinks.Add Anchor:=Sheets(Sheet8.Name).Range("F" & ch), Address:=strDirNewName
            End If
            If Dir(strDirOldName) <> "" Then
                Sheets(Sheet8.Name).Hyperlinks.Add Anchor:=Sheets(Sheet8.Name).Range("F" & ch), Address:=strDirOldName
            End If
            If (Dir(strDirNewName) = "" And Dir(strDirOldName) = "") Then
                Sheets(Sheet8.Name).Range("AQ" & ch) = "PO Is Missing"
            End If
        ch = ch + 1
        Loop
        
End Sub

 

[davesexcel]

I think it's time to split up your workbook 800k lines is a lot, though excel has the room for it, it's just too much to process. Soon just selecting one cell will take a long time.

As to the question, you could consider using a hyperlink formula =hyperlink() something you might want to investigate.

 

[Firesword]

Hi Dave

Sorry one to many 0 it's only 80k not 800k i'll try and edit the post now.

Simon

 

[Firesword]

I did think about the hyperlink formula but didn't use it, too many users with limited to no Excel knowledge and they change the formulas.

Ah penny dropping, I could use VBA to write the formula then pastespecial on mass - that would work I didn't think of that. Thanks for help I was having a senior moment.

 

[davesexcel]

Hmm, not sure if you can paste a hyperlink by formula