This is some code that will replace an image/shape that is locked to a cell with text.
Note: These bits of code are mostly for my own reference, but if anyone else finds them useful all the better.
I recently grabbed some data from a table on a web page that I wanted to use in Excel. When pasted into Excel, some of the information came across as little images instead of text in a cell. Since I wanted to be able to sort the data I had to figure out how to convert the images into some text that was in the cell.
Doing some investigating , I found that I could get identifying information about the images from the AltText information.
Here is a chunk of code to loop through the images and spit the information into a list to make sure it can be used.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
Sub GetImageAltText() ' This loops through all of the images and gets the ' alternative text for the image and places it in a ' worksheet called "List". This is done so we can check ' to make sure we can automate the conversion. Dim CurrentImage As Shape Dim CurrentSheet As Worksheet Dim OutputSheet As Worksheet Dim CurrentImageAltText As String Dim Image_Column As Integer Dim Image_Row As Integer Dim OutputRow As Integer Set CurrentSheet = Sheets("Working Data") Set OutputSheet = Sheets("List") OutputRow = 1 For Each CurrentImage In CurrentSheet.Shapes CurrentImageAltText = CurrentImage.AlternativeText Image_Column = CurrentImage.TopLeftCell.Column Image_Row = CurrentImage.TopLeftCell.Row OutputSheet.Cells(OutputRow, 1).Value = Image_Column OutputSheet.Cells(OutputRow, 2).Value = Image_Row OutputSheet.Cells(OutputRow, 3).Value = CurrentImageAltText OutputRow = OutputRow + 1 Next CurrentImage End Sub |
Once I was happy I could automate the conversion, I did. Here is the code that did that.
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
Sub ReplaceLockedImagesWithCellText() Dim CurrentImage As Shape Dim CurrentSheet As Worksheet Dim CurrentImageAltText As String Dim Image_Row As Integer Dim Image_Column As Integer Dim LastBackSlashLocation As Integer Dim NameLength As Integer Dim ShortText As String Set CurrentSheet = Sheets("Working Data") For Each CurrentImage In CurrentSheet.Shapes ' Get the location and alternative text information for the current image CurrentImageAltText = CurrentImage.AlternativeText Image_Column = CurrentImage.TopLeftCell.Column Image_Row = CurrentImage.TopLeftCell.Row ' This is being done for my particular case. This will likely need ' to be replaced by something else for other situations. It is just ' taking the long version of the AltText and replacing it with a ' shorter version. NameLength = Len(CurrentImageAltText) LastBackSlashLocation = InStrRev(CurrentImageAltText, "/") ShortText = Mid(CurrentImageAltText, LastBackSlashLocation + 1, NameLength - LastBackSlashLocation - 9) ' Now put the text in the cell under the image CurrentSheet.Cells(Image_Row, Image_Column).Value = ShortText Next CurrentImage End Sub |
The worksheet now looked like this.
Now I could remove the images.
|
1 2 3 4 5 6 7 8 9 10 11 12 |
Sub DeleteImages() Dim CurrentImage As Shape Dim CurrentSheet As Worksheet Set CurrentSheet = Sheets("Working Data") For Each CurrentImage In CurrentSheet.Shapes CurrentImage.Delete Next CurrentImage End Sub |
The end result.
Awesome! Many thanks worked like a charm