快速实现将Excel表格图片地址url替换为图片

最近接到一个需求，大致是通过腾讯文档的在线收集表，利用“健康码和行程码收集”模版方式收集用户行程信息，腾讯文档可以通过图片自动识别内容，判断是否有风险。再通过关联导出表格，即可在本地预览。

但是导出的文件有个问题，因为用户上传图片的字段都是图片的url地址，在本地查看就需要点击链接进入浏览器查看，非常不方便。所以就需要想办法把url地址替换为对应的图片，经过资料查找，大致找到两种方法。

方式一：文本转换并替换

在对应的图片url列旁边新增一列
在新增列填充公式="<table><img src='"&C2&"' height=60 width=60></table>"，src内的C2代表左边图片url那个单元格的位置。

填充excel公式

然后向下拉，复制规则到下面单元格
选中新增列对应数据的内容，复制到文本编辑器（例如记事本）

复制文本到编辑器

然后全选文本再复制并粘贴到EXCEL这一列

粘贴文本

选择图片,调整图片到合适尺寸

调整图片尺寸

缺点

不够灵活，只能针对单图场景，如果一个字段上传多个图片会有问题
操作稍微有点复杂，特别是在最后一步调整图片大小的时候

方式二：使用Visual Basic脚本自动进行处理

思路

获取存储有内容的单元格范围
对所有可用单元格进行循环，如果包含了腾讯文档图片链接，就进行下一步
对图片链接进行分割，目前腾讯文档多图是用换行符分割的
清除原单元格内容
在原单元格内插入图片，并处理单元格宽度和位置
完成

上脚本代码，里面把注释也加上了，方便读明白

' 将列数字编号转变为字母
Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

' 将url转换为图片，并插入到原位置
Sub url2img()
    ' 定义图片宽度
    w = 120
    ' 获取最后一行的行号, Rows.Count = 1048576
    lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    ' 获取最后一列的编号
    lastColumn = Col_Letter(Cells(1, Columns.Count).End(xlToLeft).Column)
    ' ActiveSheet.Name 是指当前活动的工作表的名称
    For Each c In Worksheets(ActiveSheet.Name).Range("A1:" & lastColumn & lastRow).Cells
        ' 如果值包含docs.qq.com，则将其转换为图片
        If InStr(1, c.Value, "docs.qq.com/image/") > 0 Then
            ' 将单元格位置分割为行号和列号，c.Address是形如'$D$2'格式，分割后pos(1)是列号，pos(2)是行号
            pos = Split(c.Address, "$")
            ' 当前单元格位置，格式为'D2'
            cell = c.Address(False, False)
            ' 多张图片时，图片地址是按照换行符分割的，这里对其做一下拆分
            Larray = Split(c.Value, vbNewLine)
            ' 获取单元格内图片数量
            count = UBound(Larray) - LBound(Larray) + 1
            i = 0
            ' 先将单元格内容清除
            Range(cell).ClearContents
            For Each v In Larray
                ' 当前列区域
                col = pos(1) & ":" & pos(1)
                row = pos(2) & ":" & pos(2)
                ' 选中单元格
                Range(cell).Select
                ' 插入图片
                ActiveSheet.Pictures.Insert(v).Select
                ' 设置图片宽度
                Selection.ShapeRange.Width = w
                h = Application.Ceiling(Selection.ShapeRange.Height, 1)
                ' 设置图片位置
                Selection.ShapeRange.Left = Range(cell).Left + i * (w + 5)
                ' 设置单元格宽度
                realWidth = Count * (w + 5) / 5
                If Columns(col).ColumnWidth < realWidth Then
                    Columns(col).ColumnWidth = realWidth
                End If
                ' 行高最大只支持到409，超出会报错
                If h > 409 Then
                    h = 409
                End If
                ' 设置单元格高度
                If Rows(row).RowHeight < h Then
                    Rows(row).RowHeight = h
                End If
                i = i + 1
            Next
        End If
    Next
End Sub