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