Excel macro to find words from Google Translate - vba

I have an Excel sheet with almost 30.000 words in column A and I want to create a macro to search each word in Google Translate, get their meaning (or translation), put the meaing in column B (or if there is more than more meaning in column C, column D, etc.)
Since I have almost 30.000 words, it is a very time consuming thing to search for each word by myself. It would be great if I can do this with a macro.
Any suggestions? (Google Translate is not a "must" for me. If there is another web-site or some other way to do this, I am open to suggestions)
Note: I came across with this topic, but it did not work out the way I hoped.

Since the Google Translate API is not the free service it's tricker to perform this operation. However, I found a workaround on this page Translate text using vba and I made some adjustments so it could work for your purposes. Assuming that the original words are entered into the "A" column in the spreadsheet and translations should appear in the colums on the right here is the code:
Sub test()
Dim s As String
Dim detailed_translation_results, basic_translation_results
Dim cell As Range
For Each cell In Intersect(ActiveSheet.Range("A:A"), ActiveSheet.UsedRange)
If cell.Value <> "" Then
detailed_translation_results = detailed_translation(cell.Value)
'Check whether detailed_translation_results is an array value. If yes, each detailed translation is entered into separate column, if not, basic translation is entered into the next column on the right
On Error Resume Next
ActiveSheet.Range(cell.Offset(0, 1), cell.Offset(0, UBound(detailed_translation_results) + 1)).Value = detailed_translation_results
If Err.Number <> 0 Then
cell.Offset(0, 1).Value = detailed_translation_results
End If
On Error GoTo 0
End If
Next cell
End Sub
Function detailed_translation(str)
' Tools Refrence Select Microsoft internet Control
Dim IE As Object, i As Long, j As Long
Dim inputstring As String, outputstring As String, text_to_convert As String, result_data As String, CLEAN_DATA
Dim FirstTablePosition As Long, FinalTablePosition
Set IE = CreateObject("InternetExplorer.application")
' Choose input language - Default "auto"
inputstring = "auto"
' Choose input language - Default "en"
outputstring = "en"
text_to_convert = str
'open website
IE.Visible = False
IE.navigate "http://translate.google.com/#" & inputstring & "/" & outputstring & "/" & text_to_convert
Do Until IE.ReadyState = 4
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:5"))
Do Until IE.ReadyState = 4
DoEvents
Loop
'Firstly, this function tries to extract detailed translation.
Dim TempTranslation() As String, FinalTranslation() As String
FirstTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "<tbody>")
LastTablePosition = InStr(IE.Document.getElementById("gt-lc").innerHTML, "</tbody>")
On Error Resume Next
TempTranslation() = Split(Mid(IE.Document.getElementById("gt-lc").innerHTML, FirstTablePosition, LastTablePosition - FirstTablePosition), "class=""gt-baf-cell gt-baf-word-clickable"">")
ReDim FinalTranslation(0 To UBound(TempTranslation) - 1)
For j = LBound(TempTranslation) + 1 To UBound(TempTranslation)
FinalTranslation(j - 1) = Left(TempTranslation(j), InStr(TempTranslation(j), "<") - 1)
Next j
On Error GoTo 0
Dim CheckIfDetailed
'Check whether there is detailed translation available. If not - this function returns a single translation
On Error Resume Next
CheckIfDetailed = FinalTranslation(LBound(FinalTranslation))
If Err.Number <> 0 Then
CLEAN_DATA = Split(Application.WorksheetFunction.Substitute(IE.Document.getElementById("result_box").innerHTML, "</SPAN>", ""), "<")
For j = LBound(CLEAN_DATA) To UBound(CLEAN_DATA)
result_data = result_data & Right(CLEAN_DATA(j), Len(CLEAN_DATA(j)) - InStr(CLEAN_DATA(j), ">"))
Next
detailed_translation = result_data
Exit Function
End If
On Error GoTo 0
IE.Quit
detailed_translation = FinalTranslation()
End Function
Please note that the code is extremly slow (due to anti-robot restrictions) and I cannot guarantee that Google will not block the script. However, it should work.
The only thing you should do is to choose languages in the places marked by the appropriate comment.
Alternatively, if you seek something faster, you can manipulate Application.Wait method (for example setting the value to 0:00:2 instead of 0:00:5) or google for Microsoft Translate.

Related

EPPlus fails to set formulas. Instead, it corrupts the formula XML

When I try to set cell formulas in an existing Excel file via EPPlus, the excel document is corrupted. Excel throws "We found a problem with some content in 'Excel.xlsx'. Do you want us to try to recover as much as we can? If you trust the source of this workbook, click Yes." dialog box, then says, "Removed Records: Formula from /xl/worksheets/sheet1.xml part"
If I comment out the formula set operations, the error goes away, but it fills in with formulas I didn't ask for anywhere in my code.
I have an excel file with several sheets. On one sheet, I want to set a value in column L and set formulas in columns I, J, and M. If I do this manually within Excel, everything works without error. But when I try to automate it, I Get the error messages and lose the formulas.
intended formulas:
Formula for column I: =IFNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$R,12, TRUE),"--")
Formula for column J: =IFNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$S,17,TRUE),"--")
Formula for column M: =IFNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$R,8,TRUE), "--")
Dim Hdr As String = ""
dim serverData as New List (of string) 'a list of data like A1||ServerName
' SNIP <get list data from database.> /SNIP
Dim fInfo As New FileInfo(excelFile)
Using ePack As New ExcelPackage(fInfo)
Dim mySheet As ExcelWorksheet = Nothing
'find the sheet we need.
For Each sheet As ExcelWorksheet In ePack.Workbook.Worksheets
If sheet.Name = ExcelServers Then
mySheet = sheet
Exit For
End If
Next
If IsNothing(mySheet) Then Throw New Exception("Server sheet not found.")
For Each serverRow in ServerData
If IsNothing(serverRow) OrElse InStr(serverRow, "||") = 0 Then Continue For 'skip "blank" rows
Dim Cell() As String = Split(serverRow, "||")
Dim CellAddress As String = Cell(0) 'A1..A50
Dim CellValue As String = Trim(Cell(1)) 'ServerName or table header
Dim CellAddressCol As String = Left(CellAddress, 1) ' Will always be A
Dim CellAddressRow As Integer = CellAddress.Substring(1) 'number, 1-50
If CellValue = "Oracle Server" Then
Hdr = "Ora" 'we've found a list of Oracle servers
Continue For 'skip ahead to the next value
ElseIf CellValue = "SQL Server" Then
Hdr = "Sql" 'we're done with Oracle, moving on to SQL Server servers
Continue For 'skip ahead to the next value
ElseIf CellValue = "Non-DB Servers" Then
Exit For 'we're done with all of our work.
End If
If Hdr = "Ora" Then
If Len(CellValue) < 2 Then
mySheet.Cells("L" & CellAddressRow).Value = ""
Else
mySheet.Cells("L" & CellAddressRow).Value = "P"
End If
ElseIf Hdr = "Sql" Then
If Len(CellValue) < 2 Then
mySheet.Cells("I" & CellAddressRow).Value = ""
mySheet.Cells("J" & CellAddressRow).Value = ""
mySheet.Cells("L" & CellAddressRow).Value = ""
mySheet.Cells("M" & CellAddressRow).Value = ""
ElseIf CellValue = "Cluster1" Or CellValue = "Cluster2" Then
mySheet.Cells("I" & CellAddressRow).Value = ""
mySheet.Cells("J" & CellAddressRow).Value = ""
mySheet.Cells("L" & CellAddressRow).Value = "C"
mySheet.Cells("M" & CellAddressRow).Value = ""
Else 'data row.
mySheet.Cells("I" & CellAddressRow).Formula = "IFNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$R,12, TRUE),""--"")"
mySheet.Cells("J" & CellAddressRow).Formula = "IFNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$S,17,TRUE),""--"")"
mySheet.Cells("L" & CellAddressRow).Value = "V"
mySheet.Cells("M" & CellAddressRow).Formula = "ifNA(VLOOKUP([#[SQL Server]],SqlVersions!$C:$R,8,FALSE),""--"")"
End If ' /empty row? Cluster row? other server row?
End If ' /Oracle or SQL?
Next
ePack.Save()
End Using
I expect to get a series of rows where the rows after "Oracle" get a "P" in column L and the rows after "SQL Server" have lookup formulas in columns I, J, and M, with a "V" in column L.
If I leave the .Formula = code in place, I get the errors. If I comment out the .Formula lines, I instead get the formula "=70+65" for Oracle rows and "=159+799" for SQL Server rows.
The end result should look something like this:
(Note that the Oracle rows and two header rows are just text and aren't modified by this code.)
Oracle Server,,,,,,,,Version,Patch,,P V or C, End of Life
Oracle1,,,,,,,,12.2.0.1,27937914,,P,
Oracle,,,,,,,,12.2.0.1,27937914,,P,
,,,,,,,,
Sql Server,,,,,,,,Version,Patch,,P V or C,End of Life
Cluster1,,,,,,,,,,,C,7/14/2026
Cluster2,,,,,,,,,,C,
Sql1,,,,,,,2016 Ent 13.0.5337,SP2 CU7 Up,,V,10/12/2027
Sql2,,,,,,,2017 Ent 14.0.3223,CU16,,V,7/14/2026
[...]
sql32,,,,,,,2016 Ent 13.0.5426,SP2 CU8,,V,7/14/2016
,,,,,,,,
Non-DB Servers,,,,,,,,
But what I'm getting, after I accept the error message request to repair is:
Oracle Server,,,,,,,,Version,Patch,,P V or C, End of Life
Oracle1,,,,,,,,12.2.0.1,27937914,,135,
Oracle,,,,,,,,12.2.0.1,27937914,,135,
,,,,,,,,,,,135
Sql Server,,,,,,,,Version,Patch,,P V or C,End of Life
Cluster1,,,,,,,,,,958,#N/A
Cluster2,,,,,,,,,,958,#N/A
Sql1,,,,,,,,,,958,10/12/2027
Sql2,,,,,,,,,,958,7/14/2026
[...]
sql32,,,,,,,,,,958,7/14/2016
,,,,,,,,,,958,#N/A
Non-DB Servers,,,,,,,,
I have no idea where those formulas are coming from at all, as they are nowhere in my code, ever.
Edit
Here is the Excel file (scrubbed of actual server names) as it should be.
And here is the Excel file (also scrubbed) as this code leaves it.
When I open and save() the sample you provided, without doing any edit whatsoever, it always shows me the problem with some content error (tried on Windows 10 with Office 365 and .NET 4.7.2). Because of this I cannot be certain of the cause in your specific situation.
However, I notice EPPlus has a problem when 'translating' formulae when using a Table within Excel. As an example a simple vlookup:
=VLOOKUP(A2,Data!A:B,2,FALSE)
When the above formula is used in a Table, it is changed after being saved with EPPlus and is now erroneous (showing #NAME?) because of the A:B:B:
=VLOOKUP(A2,Data!A:B:B,2,FALSE)
Finding out if this is a bug in EPPlus will require some extensive debugging, with the ExcelCellBase.Translate method being a good start. Also, someone else might already have found it (EPPlus has an relatively large list of open issues.
Sorry if this does not help. I think what I showed is a bug in EPPlus, but I do now know if it it the cause for your problem.

Excel 2016 VBA - Compare 2 PivotTables fields for matching values

Hi please can someone help, Excel 2016 VBA PivotTable objects. I rarely develop in Excel VBA.
Overall goal:
Compare a single column [P_ID] value list from PivotTable2 against PivotTable1 if they exist or not to enable filtering on those valid values in PivotTable1.
I have some Excel 2016 VBA code which I have adapted from a previous answer from a different internet source.
Logic is: gather data from PivotTable2 from the ComparisonTable dataset (in PowerPivot model), field [P_ID] list of values. Generate a test line as input into function to test for existence of field and value in PivotTable1 against the Mastertable dataset, if true add the line as valid if not skip the line.
Finally filter PivotTable1 with the VALID P_ID values.
It works to a point until it gets to the bFieldItemExists function which generates an error:
Run-time error '1004'
Unable to get the PivotItems property of the PivotField class
Can someone please correct the way of this not working?
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
Dim MyArray As Variant, _
ar As Variant, _
x As String, _
y As String, _
str As Variant
MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("[ComparisonTable].[P_ID].[P_ID]").DataRange
For Each ar In MyArray
x = "[MasterTable].[P_ID].&[" & ar & "]"
If ar <> "" And bFieldItemExists(x) = True Then
If str = "" Then
str = "[MasterTable].[P_ID].&[" & ar & "]"
Else
str = str & "," & "[MasterTable].[P_ID].&[" & ar & "]"
End If
End If
Next ar
Dim str2() As String
str2 = Split(str, ",")
Application.EnableEvents = False
Application.ScreenUpdating = False
ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").VisibleItemsList = Array(str2)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function bFieldItemExists(strName As String) As Boolean
Dim strTemp As Variant
' This line does not work!?
strTemp = ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").PivotItems(strName)
If Err = 0 Then bFieldItemExists = True Else bFieldItemExists = False
End Function
The 1004 error occurred due to the use of square brackets [ ]. Remove those.
You also need to use the key word Set when you set an object equal to something. For example Set MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("ComparisonTable.P_ID.[P_ID").DataRange.
If you don't use Set you will get a VBA run-time error dialog that says Run-time error '91': Object variable or With block variable not set
I cannot guarantee that my edits will completely solve your problem since I don't have your data set and cannot fully test your code. You will need to use the Debug mode in the VBA editor and single step through the code. To this set a breakpoint on the Set mDataRange = Active.... To set a breakpoint go to the Debug menu and choose the "Toggle Breakpoint" sub-menu item or you can press F9 to set the breakpoint.
Now when you make a change to the Pivot table, the Worksheet_PivotTableUpdate event will fire and the code will top execution at that point.
After the code stops executing due to the breakpoint, you can press the F8 key to single step through your code. If you want to resume execution to the next breakpoint you can press F5. Also when you get the VBA error dialog box, you can hit Debug and then use the F8 key to single step or use the debug windows to see what your variables and objects contain. I'm sure there are some good youtube videos on VBA debugging.
As you single step through the code, you can observe what each variable/object contains using the Immediate window, the Watches window and the Locals window. To open these windows, go to the menu item View and click on each of these sub-menu items.
Here's how you need to edit your code before debugging.
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'Better practice is to not use the underscore character to
'continue a Dim declaration line
Dim mDataRange As Range
Dim ar As Range
Dim x As String
Dim y As String
Dim str As Variant
'Use Set to assign the object mDataRange a reference to the the right
'hand side of the equation. Remove the square brackets
'MyArray = ActiveSheet.PivotTables("PivotTable2").PivotFields("[ComparisonTable].[P_ID].[P_ID]").DataRange
Set mDataRange = ActiveSheet.PivotTables("PivotTable2").PivotFields("ComparisonTable.P_ID.P_ID").DataRange
For Each ar In mDataRange
'You need to specify what proprerty from ar you
'want to assign to x. Assuming the value stored in
'ar.Value2 is a string, this should work.
'We use value2 because it is the unformmated value
'and is slightly quicker to access than the Text or Value
'properties
'x = "[MasterTable].[P_ID].&[" & ar & "]"
x = "MasterTable.P_ID." & ar.Value2
'Once again specify the Value2 property as containing
'what value you want to test
If ar.Value2 <> "" And bFieldItemExists(x) = True Then
If str = "" Then
'Remove the square brackets and use the specific property
'str = "[MasterTable].[P_ID].&[" & ar & "]"
str = "MasterTable.P_ID." & ar.Value2
Else
'Remove the square brackets and use the specific property
'str = str & "," & "[MasterTable].[P_ID].&[" & ar & "]"
str = str & "," & "MasterTable.P_ID." & ar.Value2
End If
End If
Next ar
Dim str2() As String
str2 = Split(str, ",")
Application.EnableEvents = False
Application.ScreenUpdating = False
'Remove square brackets
'ActiveSheet.PivotTables("PivotTable1").PivotFields("[MasterTable].[P_ID].[P_ID]").VisibleItemsList = Array(str2)
ActiveSheet.PivotTables("PivotTable1").PivotFields("MasterTable.P_ID.P_ID").VisibleItemsList = Array(str2)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function bFieldItemExists(strName As String) As Boolean
'Declare a PivotItem to accept the return value
Dim pvItem As PivotItem
'Since you want to trap for an error, you'll need to let the VBA runtime know
'The following code is a pseudo Try/Catch. This tells the VBA runtime to skip
'the fact an error occured and continue on to the next statement.
'Your next statement should deal with the error condition
On Error Resume Next
'Use Set whenever assigning an object it's "value" or reference in reality
Set pvItem = ActiveSheet.PivotTables("PivotTable1").PivotFields("MasterTable.P_ID.P_ID").PivotItems(strName)
'Assuming that an error gets thrown when strName is not found in the pivot
'Err is the error object. You should access the property you wish to test
If Err.Number = 0 Then
bFieldItemExists = True
Else
bFieldItemExists = False
End If
'Return to normal error functioning
On Error GoTo 0
End Function
Finally, I realize that some of this should be in the comments section, but there was too much I needed to explain to help Learner74. BUT most importantly, I hope I helped him. I have used so many suggestions, recommendations and explanations from the VBA Stack Overflow exchange through the years, I just want to pay it back by paying it forward.
Additional USEFUL Links:
Chip Pearson is the go to site and person for all things VBA
Paul Kelly's Excel Macro Mastery is another go to site for Excel and VBA questions.
Microsoft Excel Object Model which is sometimes useful, but needs improvement. Too many of the objects lack examples, but can at least point you in the right direction.

Catalog word file data in MS Access using VBA

I've been asked to create a MS access database that catalogs all the data that is stored in MS Word Files. The Word files have tables that contain the data.
For example, "Customer Name:" | Customer data | "Date" | Date data
I have used MS Access to loop and open each file using objects Word.Application and Word.Document .
Then I use a 2nd loop on i using this command to get the value in the cell: worddoc.Tables(tableindex).Range.Cells(i).Range.Value
HOWEVER if the cell contains a dropdown box, I do not get the value in the dropdown box; I get a square character.
1) Is there a way to determine what type of data is in the cell? Most of the time it would be Text, Textbox, or Dropdown box.
2) When it is a Dropdown box, how do I get the data from it?
I hope I provided enough information. please ask if you need more info.
Maybe something like this (for example - assuming you have "content controls" and not some other type of control...)
Sub Tester()
Dim t As Table, r, c, rw, cel As Cell, cc
Set t = ActiveDocument.Tables(1)
For r = 1 To t.Rows.Count
Set rw = t.Rows(r)
For c = 1 To rw.Cells.Count
Set cel = rw.Cells(c)
Debug.Print r, c, GetContent(cel)
Next c
Next r
End Sub
Function GetContent(c As Cell)
Dim cc, con, sep
Set cc = c.Range.ContentControls
If cc.Count = 0 Then
'stripping off "end of cell" marker...
GetContent = Right(c.Range.Text, Len(c.Range.Text) - 2)
Else
For Each con In cc
GetContent = GetContent & sep & con.Range.Text
sep = " "
Next con
End If
End Function
The little square box you are getting is the end of cell marker. In a table cell, it functions kind of like a last paragraph. So ... you have to get rid of it before you do anything else.
The following is some example test code, just looking at one cell in a table, but use it as a guide to fit into your process of looping thru the various cells. My other caveat is I took your reference to a "Textbook" literally in this example. If what you meant was a text box content control, then you can ignore that portion of this example.
Dim rng As Range, cc As ContentControl, shp As Shape
Set rng = ActiveDocument.Tables(1).rows(1).Cells(1).Range
rng.MoveEnd wdCharacter, -1
If rng.ContentControls.Count > 0 Then
Set cc = rng.ContentControls(1)
Debug.Print cc.Range.Text
ElseIf rng.ShapeRange.Count > 0 Then
If rng.ShapeRange(1).Type = msoTextBox Then
Set shp = rng.ShapeRange(1)
If shp.TextFrame.HasText Then
Debug.Print shp.TextFrame.TextRange.Text
End If
End If
Else
If Not rng.Text = vbNullString Then
Debug.Print rng.Text
End If
End If

Check If Item Exists in Collection with Application.Match in VBA

I have a problem with my code for a Macro I am writing for Excel.
It specifically relates to the Method Application.Match or alternatively Application.WorksheetFunction.Match
I have an array of strings where I store the names of all companies in a list
Dim CompanyID() As String
ReDim CompanyID(NumCO)
For i = 1 To NumCO
CompanyID(i) = Worksheets("Sheet1").Cells(i, 1).Value
Next i
Then I creat a Collection to only contain all different companies
Dim DifCO As New Collection, a
On Error Resume Next
For Each a In CompanyID
DifCO.Add a, a
Next
Later in my code I run through the companies again to relate them with certain properties, for which I need the Index of where the company is saved in the Collection DifCO. However I haven't been able to get it with Application.Match
My program does not seem to do anything in that line and to prove it I have tried to print the Index in a MsgBox but the MsgBox doesn't appear and it doesn't even sends an error message.
For i to NumCO
MsgBox (Application.WorksheetFunction.Match(CompanyID(i), DifCO, 0))
Next i
I have tried different things as using Application.Match and moving the elements of the Collection to another string's array but the result is the same.
I know the code loops correctly since I have observed it in the step by step debugging option. But I have ran out of ideas on what could be the problem so here I am asking this community.
As Mat indicates in comments on the OP, it looks like you've used On Error Resume Next without On Error GoTo 0, so the handler is swallowing the error and you're not seeing it, and the MsgBox is not displayed.
When debugging, there is an option to Break on All Errors which can be useful, although it's rather a pain in the ass in very complicated applications, for something like this it would've flagged the problem for you immediately. In the VBE under Tools > Options > General:
Generally you want to avoid Resume Next except for very small and purposeful error traps. Leaving it open like that is bound to cause errors further in your code which are then difficult to troubleshoot (as you've noticed!).
For your solution, you may use an ArrayList
Dim list as Object
Set list = CreateObject("System.Collections.ArrayList")
For Each a In CompanyID
If Not list.Contains(a) Then list.Add(a)
Next
Then, get the index by dumping the ArrayList to a variant array using the ToArray method, and then testing that with Application.Match:
Dim arr, foundAt
arr = list.ToArray()
For i = 1 To NumCO
foundAt = Application.Match(CompanyID(i), arr, 0)
If Not IsError(foundAt) Then
MsgBox foundAt
End If
Next i
Otherwise the usual method of getting index from a collection or an array is simply brute-force iteration over the items, and it's probably best to just spin off an ad-hoc function to do these things, rather than cluttering the main procedures with extra loops:
Sub collExample()
Dim c As New Collection
c.Add "9"
c.Add "14"
c.Add "3"
c.Add "15"
c.Add "4"
c.Add "3"
Debug.Print colItmExists(c, "5") '~~> False
Debug.Print colItmExists(c, "10") '~~> True
Debug.Print colItmFirstIndex(c, "3") '~~> 3
Debug.Print colItmFirstIndex(c, "17") '~~> -1
End Sub
Function colItmExists(col As Collection, itm) As Boolean
Dim i, ret As Boolean
For i = 1 To col.Count
If col(i) = itm Then
ret = True
Exit For
End If
Next
colItmExists = ret
End Function
Function colItmFirstIndex(col As Collection, itm) As Long
Dim ret As Long
If Not colItmExists(col, itm) Then
ret = -1
Else
For i = 1 To col.Count
If col(i) = itm Then
ret = i
Exit For
End If
Next
End If
colItmFirstIndex = ret
End Function

Excel convert URL to images (1004)

I have an excel document linked to an SQL database which contains several columns of image URLs.
One of those URLs looks like this:
https://imissit.blob.core.windows.net/iris/596480cf967e0c990c37fba3725ada0c/814040e2-0ccb-4b05-bdb3-d9dc9cc798d9/texture.png
I found different approaches and methods on how to convert those URLs to images ( e.g.
Excel VBA Insert Images From Image Name in Column and https://superuser.com/questions/940861/how-can-i-display-a-url-as-an-image-in-an-excel-cell) within the excel document using macros. I tried those approaches but none of them works for my kind of URL. I tried other URLs (random images on the web, http and https and for those images it WORKS).
This is one of the snippets I tried, which works for other images:
Sub InstallPictures()
Dim i As Long, v As String
For i = 2 To 2
v = Cells(i, "O").Value
If v = "" Then Exit Sub
With ActiveSheet.Pictures
.Insert (v)
End With
Next i
End Sub
Anyway when trying it with my URL I get a runtime error 1004: Insert method of picture object cannot be executed(translated). Different approaches result in slightly different runtime errors (although 1004 is consistent).
Here are some image URLs I tried that work:
https://docs.oracle.com/cd/E21454_01/html/821-2584/figures/HTTPS_Collab_Sample.png
http://www.w3schools.com/css/paris.jpg
https://scontent.ftxl1-1.fna.fbcdn.net/v/t1.0-9/13043727_278733959131361_2241170037980408109_n.jpg?oh=bec505696c5f66cde0cc3b574a70547c&oe=58CC35C5
What is different from my URL to the others and why those methods don't work? What is the correct approach?
The problem (as far as I can tell) is not your device, but it's on the server that is hosting the image, and is failing to return the document. I'm not sure where Tim's comment above (pertaining to the 206 response code) comes from, but if that's the case, or if the URL is returning some error code, then your VBA would also fail and there is likely nothing you can do to resolve that if the problem is at the host.
I manually enter the URL today and download the file, no problem.
I check the response code and it's returning correctly a 200 (success).
The best you can do at this point is to simply trap the error, and flag it for later review.
In my test, I used some deliberatly bad URL just to ensure error handling is working as expected. These are the only ones that failed for me.
Here's the code I used, modified only slightly from yours and includes an error-handler to add a COMMENT to the cells which URLs return the error. This way you can later review manually and add those images if needed.
Sub InstallPictures()
Dim i As Long
Dim v As String
Dim cl As Range
Dim pic As Shape
Dim errors As New Collection
i = 2
Set cl = Cells(i, 15)
Do While Trim(cl.Value) <> vbNullString
v = Trim(cl.Value)
cl.ClearComments
With ActiveSheet.Pictures
On Error GoTo ErrHandler
Set p = .Insert(Trim(v))
On Error GoTo 0
' I added this code to resize & arrange the pictures
' you can remove it if you don't need it
p.TopLeftCell = cl.Offset(0, -1)
p.Top = cl.Offset(0, -1).Top
p.Left = cl.Offset(0, -1).Left
p.Height = Cells(i, 15).Height
p.Width = Cells(1, 15).Width
'''''''''''''''''''''''''''''
End With
NextCell:
i = i + 1
Set cl = Cells(i, 15)
Loop
If errors.Count > 0 Then
MsgBox "There were errors, please review the comments as some files may need to be manually downloaded"
End If
Exit Sub
ErrHandler:
Call ErrorNote(v, cl, errors)
Resume NextCell
End Sub
Private Sub ErrorNote(url$, cl As Range, ByRef errs As Collection)
' Adds an item to the errs collection and flags the offending
' cell with a Comment indicating the error occurred.
On Error Resume Next
errs.Add (url)
With cl
.ClearComments
.AddComment ("Error with URL: " & vbCrLf & url)
End With
End Sub