How to optimize my script to avoid making duplication of results?

[shahin]

Is there any way I can use dictionary (key, value pair) in the below script so that it can look for the key and it's value whether it is present as in, if any image is already present, it will skip that and if not then parse the image? The script can parse the image if I run it but the problem with it is: it again parses the image if I run again and so on even though scraped pictures are already there.

Sub PlacingImages()
    Dim img As String, pics As Picture, cel As Range

    For Each cel In Range("C2", Range("B2").End(xlDown).Offset(0, 1))
        img = cel.Offset(0, -1)
        Set pics = Sheets("Sheet1").Pictures.Insert(img)
        With pics
            .ShapeRange.LockAspectRatio = msoFalse
            .Width = cel.Width
            .Height = cel.Height
            .Top = Rows(cel.Row).Top
            .Left = Columns(cel.Column).Left
        End With
    Next cel
End Sub

Placing these in Range(B2:B5) and the output will be reflected in the adjacent cells which means Range("C2:C5").

https://pic.yify-torrent.org/20170824/55408/lowriders-2017-1080p-poster.jpg
https://pic.yify-torrent.org/20170824/55407/wind-chill-2007-1080p-poster.jpg
https://pic.yify-torrent.org/20170824/55406/serial-mom-1994-1080p-poster.jpg

 

[shrivallabha]

Here's one which is untested. I have added comments for your reference. Verify if it works for you.

Sub PlacingImagesDict()
    Dim img As String, pics As Picture, cel As Range
    Dim objDict As Object                              'Variable
    Set objDict = CreateObject("Scripting.Dictionary") 'Create
    objDict.CompareMode = vbTextCompare                'Set comparison to text mode
    For Each cel In Range("C2", Range("B2").End(xlDown).Offset(0, 1))
        img = cel.Offset(0, -1)
        If Not objDict.Exists(img) Then                'Test if it already exists
            Set pics = Sheets("Sheet1").Pictures.Insert(img)
            With pics
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With
            objDict.Add img, img                        'Add so that we can check next time!
        End If
    Next cel
    Set objDict = Nothing                              'Release from memory
End Sub

 

[shahin]

Thanks a zillion shrivallabha to care for an answer. Every time I run your script, it also fetches the expected items even though the positions are already filled in.

 

[shrivallabha]

So the code runs but the result is not on expected lines?

I assume that the value being passed to variable "img" is the one you want to verify against stored list in Dictionary and avoid getting duplicated.

Without knowing what's being passed to Dictionary and what you are perceiving as "unique" it will be harder to answer.

 

[shahin]

I just used your script with the three image links I've pasted above to verify whether It meets the expectation not producing any duplicate image no matter how many times I execute my script. I've uploaded a file to make things clearer. Please, go it through. Thanks in advance.

 

[shrivallabha]

All three cells have unique string so all lines will be executed.

Can you explain the criterion for unique image please?

PS: I ran the script in office and your code doesn't work here. It fails on .Pictures.Insert line. I have Excel 2010 here in the office. I will test this at home in the evening where I have Excel 2016.

 

[shahin]

Sorry for my linguistic difficulty, if there is any. I meant, if I run the script for the first time, I get three pictures in the spreadsheet. Now, without deleting those newly scraped pictures, If i run the script again, I can see another three pictures and so on. That means If i run my script 5 times I will have fifteen pictures in the spreadsheet. My point is If I run 100 times, the picture will always be three in number because the dictionary will take a look if there is any duplication is being produced. Thanks. Btw, I'm using excel 2013.

 

[NARAYANK991]

Sorry for my linguistic difficulty, if there is any. I meant, if I run the script for the first time, I get three pictures in the spreadsheet. Now, without deleting those newly scraped pictures, If i run the script again, I can see another three pictures and so on. That means If i run my script 5 times I will have fifteen pictures in the spreadsheet. My point is If I run 100 times, the picture will always be three in number because the dictionary will take a look if there is any duplication is being produced. Thanks. Btw, I'm using excel 2013.

Hi ,

A dictionary only detects duplicates within a run ; not between runs !

Once the code completes execution , the dictionary no longer exists ; on a second run of the procedure , the dictionary is recreated.

Narayan

 

[shahin]

Oh I see!!! Thanks for your comment Narayan. That means, dictionary has got noting to do with what i'm expecting. Basically, this idea comes to my mind cause the other day you helped me with a script to delete duplicate rows with data filled in.

 

[NARAYANK991]

Hi ,

The easiest way would be to first delete all linked pictures each time the code is run !

The rest of the code given by Shrivallabha will then paste the images afresh.

Narayan

 

[shrivallabha]

Sorry for my linguistic difficulty, if there is any.

You must be kidding! There's a simple way to handle this.

            With pics
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With

In this block add setting to manage picture name

            With pics
                .Name = img '\\ Added here
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With

And then you can test whether image with particular name exists or not!

 

[shrivallabha]

PS: I ran the script in office and your code doesn't work here. It fails on .Pictures.Insert line. I have Excel 2010 here in the office. I will test this at home in the evening where I have Excel 2016.

Issue with this was I didn't have access to urls mentioned.

Here's complete code for what I suggested!

Sub PlacingImagesDict()
  Dim img As String, pics As Picture, cel As Range
  For Each cel In Range("C2", Range("B2").End(xlDown).Offset(0, 1))
        img = cel.Offset(0, -1)
        On Error Resume Next
        Set pics = Sheets("Sheet1").Pictures(img)
        On Error GoTo 0
        If pics Is Nothing Then
          Set pics = Sheets("Sheet1").Pictures.Insert(img)
            With pics
                .Name = img
                .ShapeRange.LockAspectRatio = msoFalse
                .Width = cel.Width
                .Height = cel.Height
                .Top = Rows(cel.Row).Top
                .Left = Columns(cel.Column).Left
            End With
            Set pics = Nothing
        Else
            Debug.Print img & " Exists!"
        End If
    Next cel
End Sub

 

[shahin]

No way. It is what I was expecting. Thanks shrivallabha for your sweet, robust and effective solution. it works great now.