Excel VBA实现图片网址变为图片，以及导入本地图片

前段时间爬了一些数据，但是只有excel文本，文本中有图片地址，想让图片显示出来，这就需要用到VBA了。

1-建立一个宏，名字随意


然后点编辑，复制以下内容（如果你的地址不在第一列，可以更改cells(i,1) i的值，或者把数据弄到第一列）

On Error Resume Next

i = 1

Do While i <= Cells(Rows.Count, 1).End(xlUp).Row

Cells(i, 1).Select
link = Cells(i, 1).Value
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=link '把文本地址都变成超链接

i = i + 1
Loop

Dim HLK As Hyperlink, Rng As Range
For Each HLK In ActiveSheet.Hyperlinks '循环活动工作表中的各个超链接
If UCase(HLK.Address) Like "*.JPG" Or UCase(HLK.Address) Like "*.JPEG" Or UCase(HLK.Address) Like "*.PNG" Or UCase(HLK.Address) Like "*.GIF" Then '如果链接的位置是jpg或gif图片(此处仅针对此两种图片类型,更多类型可以通过建立数组或字典或正则来判断)
Set Rng = HLK.Parent.Offset(, 0) '设定插入目标图片的位置
With ActiveSheet.Pictures.Insert(HLK.Address) '插入链接地址中的图片

If .Height / .Width > Rng.Height / Rng.Width Then '判断图片纵横比与单元格纵横比的比值以确定针对单元格缩放的比例
.Top = Rng.Top
.Left = Rng.Left + (Rng.Width - .Width * Rng.Height / .Height) / 2
.Width = .Width * Rng.Height / .Height
.Height = Rng.Height
Else
.Left = Rng.Left
.Top = Rng.Top + (Rng.Height - .Height * Rng.Width / .Width) / 2
.Height = .Height * Rng.Width / .Width
.Width = Rng.Width
End If
End With
HLK.Parent.Value = "" '删除单元格的图片链接
End If
Next

设置下需要的行高，行高就在导入后显示的图片的高度，最后点宏点执行

如果图片本地一块下载了的话，可以直接插入图片，用如下的代码
本地插入图片，不只是路径

For Each shp In ActiveSheet.Shapes
shp.Delete
Next

On Error Resume Next
addr = ThisWorkbook.Path & "\图库"   '后面这里更改成你的图片文件夹的名字
AcolumnLastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To AcolumnLastRow
    Set Rng = Cells(i, 2)
    Filename = addr & "\" & Cells(i, 1).Text 'Cells(i, 1).Text 是图片的名字
    Set pic = ActiveSheet.Shapes.AddPicture(Filename, False, True, Rng.Left, Rng.Top, -1, -1)
    pic.Height = Rng.Height
    pic.Left = (Rng.Width - pic.Width) / 2 + Rng.Left
Next i

一般图片会比较大，可以单击一张图，ctrl+A,全选，然后点格式，压缩，选96ppi

最后赠送一个批量更改本地图片名称的

批量更改文件名称，先获取，后更改

Sub 批量获取文件名()
Cells = ""
Dim sfso
Dim myPath As String
Dim Sh As Object
Dim Folder As Object
Application.ScreenUpdating = False
On Error Resume Next
Set sfso = CreateObject("Scripting.FileSystemObject")
Set Sh = CreateObject("shell.application")
Set Folder = Sh.BrowseForFolder(0, "", 0, "")
If Not Folder Is Nothing Then
  myPath = Folder.Items.Item.Path
End If
Application.ScreenUpdating = True
Cells(1, 1) = "旧版名称"
Cells(1, 2) = "文件类型"
Cells(1, 3) = "所在位置"
Cells(1, 4) = "新版名称"
Call 直接提取文件名(myPath & "\")
End Sub
Sub 直接提取文件名(myPath As String)
    Dim i As Long
    Dim myTxt As String
    i = Range("A1048576").End(xlUp).Row
    myTxt = Dir(myPath, 31)
    Do While myTxt <> ""
    On Error Resume Next
        If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then
            i = i + 1
            Cells(i, 1) = "'" & myTxt
            If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then
                Cells(i, 2) = "文件夹"
            Else
                Cells(i, 2) = "文件"
            End If
            Cells(i, 3) = Left(myPath, Len(myPath) - 1)
        End If
        myTxt = Dir
    Loop
End Sub
Sub 批量重命名()
Dim y_name As String
Dim x_name As String
For i = 2 To Range("A1048576").End(xlUp).Row
   y_name = Cells(i, 3) & "\" & Cells(i, 1)
   x_name = Cells(i, 3) & "\" & Cells(i, 4)
   On Error Resume Next
   Name y_name As x_name
Next
End Sub