Can anyone suggest a way to make this macro run mach fast as it take a very long time to run?

[tonywatsonhelp]

Hi Everyone,
I was woundering if anyone know a quicker way to insert images from urls into a sheet,
this currently take about two hours to run on 5000 lines

any suggestions would be greatly apreciated.
hears the code i currently use?

Sub Hyperlink_Insert()

    Dim Pshp As Shape
    Dim xRg As Range
    Dim xCol As Long
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Dim shp As Shape

For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 7) = "Picture" Then
    shp.Delete
    End If
Next shp


lr1 = Thum.Cells(Rows.Count, "B").End(xlUp).Row
If lr1 <= 10 Then
lr1 = 10
End If

    
    Set rng = Thum.Range("B10:B" & lr1)
    For Each cell In rng
    Application.StatusBar = "Progress: " & cell.Row & " of " & lr1
    
        filenam = cell
        Thum.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoTrue

            .Height = xRg.Height * 0.9
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
'            .OnAction = "Picture_Click_Big"
        End With
lab:
    Set Pshp = Nothing
    Range("A1").Select
    Next
    Application.ScreenUpdating = True



Application.StatusBar = False
End Sub

 

[johnnyL]

Without having a file to test on, I can recommend a few things:

1) Get rid of the 'On Error Resume Next' line of code. That will only hide errors that you run into, it should never be placed at the beginning of your code and left in tact for the entire procedure.
2) Limit or get rid of entirely the 'Application.StatusBar = "Progress: " & cell.Row & " of " & lr1' line of code. Updating the StatusBar slows your script every time you do it.
3) Change:

            Set Pshp = Nothing
            Range("A1").Select
        Next

to:

        Next
'
        Set Pshp = Nothing
        Range("A1").Select

 

[tonywatsonhelp]

wow, that made a noticeable difference, thanks JohnyL,
it still takes some time to run but I'd say half as long as it did,
if anyone else has anything to either complement the above or suggest a better way of doing this I'd be happy to hear.
Thanks
Tony

 

[johnnyL]

Do you have formulas on that sheet?

 

[tonywatsonhelp]

yes i do

 

[johnnyL]

In that case, you possibly could benefit from changing:

        Application.ScreenUpdating = False

to:

        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

Also change:

        Application.ScreenUpdating = True

to:

        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True