VBA批量插图位置越来越不对问题解决方法

VBA批量插图,随着插图数量多增加,位置越来越不对？

https://bbs.wps.cn/topic/78059

今天有看到小伙伴提问这个问题，其实这个问题已经存在很多年了，下面我们来重现这个问题。

1. 新建一个工作表，默认行高（13.5）。

使用以下vba代码插入图片。

Sub kkk()
    t = "C:\Users\kk\Desktop\图片\"
    k = Cells(Rows.Count, 2).End(3).Row
    arr = Range("b1:b" & k)
    ActiveSheet.DrawingObjects.Delete
    For x = 2 To k
        If arr(x, 1) <> "" Then
            Set i_range = Cells(x, 1)
            i_top = i_range.Top + 2
            i_left = i_range.Left + 2
            i_height = i_range.Height * 6 - 4
            i_width = i_range.Width - 4
        ActiveSheet.Shapes.AddPicture t & arr(x, 1) & ".jpg", msoFalse, msoTrue, i_left, i_top, i_width, i_height
        End If
    Next
End Sub

插入后位置正常，如下

当设置单元格的行高为其他值后（我这里设置的是 20 ），插入图片后位置发生错误，如下图所示。

通过目前的测试可以得知，插入图片后图片位置不对的原因是单元格行高的问题导致的（也有可能是其他的原因），根据当前问题可以下面的代码来解决，代码如下

Sub kkk_2()
    t = "C:\Users\kk\Desktop\图片\"
    k = Cells(Rows.Count, 2).End(3).Row
    arr = Range("b1:b" & k)
    ReDim brr(1 To k)
    ActiveSheet.DrawingObjects.Delete
    For x = 1 To k
        brr(x) = Cells(x, 1).RowHeight
    Next
    Range("1:" & k).RowHeight = 13.5
    For x = k To 2 Step -1
        Cells(x, 1).RowHeight = brr(x)
        If arr(x, 1) <> "" Then
            Set i_range = Cells(x, 1)
            i_top = i_range.Top + 2
            i_left = i_range.Left + 2
            i_height = i_range.Height * 6 - 4
            i_width = i_range.Width - 4
        ActiveSheet.Shapes.AddPicture t & arr(x, 1) & ".jpg", msoFalse, msoTrue, i_left, i_top, i_width, i_height
        End If
    Next
    Cells(1, 1).RowHeight = brr(1)
End Sub

代码逻辑如下

1. 创建一个数组，循环当前行数，记录当前每一行的单元格行高。

2. 将所有单元格行高设置成默认的13.5。

3. 倒序循环恢复行高的同时，插入图片。

修改后的代码运行结果如下图所示

如果以上的方法插入图片的位置还是不对，我们还可以使用第二种方法，代码如下

Sub kkk_3()
    t = "C:\Users\kk\Desktop\图片\"
    k = Cells(Rows.Count, 2).End(3).Row
    arr = Range("b1:b" & k)
    ActiveSheet.DrawingObjects.Delete
    Set sh = Sheets("辅助表")
    sh.Range("a:a").ColumnWidth = Range("a:a").ColumnWidth
    For x = 2 To k
        If arr(x, 1) <> "" Then
            Rows(x).Resize(6).Copy sh.Range("a1")
            Set i_range = Cells(x, 1)
            i_top = 2
            i_left = 2
            i_height = i_range.Height * 6 - 2
            i_width = i_range.Width - 4
            sh.Shapes.AddPicture t & arr(x, 1) & ".jpg", msoFalse, msoTrue, i_left, i_top, i_width, i_height
            sh.Range("a1:a6").Copy Cells(x, 1)
            sh.DrawingObjects.Delete
        End If
    Next
End Sub

代码逻辑如下和准备工作如下

准备工作：新建一个辅助工作表，命名为【辅助表】（也可以使用代码新建）。

代码逻辑：

1. 同步辅助表A列的列宽。

2. 循环的时候如果需要插入图片，复制要插入图片的单元格所在行，粘贴到辅助行的第一行（需要整行粘贴）

3. 将图片插入到辅助表的A1单元格（因为插入图片到A1单元格 位置是百分百正确的）

4. 将A1单元格及下方单元格（合并单元格）复制粘贴回 要插入工作表所在行。

5. 清除辅助表所有对象（刚刚插入的图片）。

代码运行后效果如下

通过以上两种方法可以间接的解决WPS插入照片位置不对的问题。

注：样例代码主要是演示解决此问题的原理，所以代码没有加详细的容错处理，实际使用前应该做以下判断处理，

1. 插入图片前要判断文件是否存在。

2. 没有判断合并单元格的实际行数，默认都是6行。

3. 如果有合并单元格，应循环获取每行单元格的行高。

希望WPS以后可以解决这个问题吧（希望不大。。。）

最后，如果可以，可以插入嵌入单元格图片，就没有这个问题了，代码也更简洁

需要在JS环境下使用，VBA不支持这个方法。

Range("A1").GetRangeEx().InsertCellPicture("C:\\Users\\kk\\Desktop\\图.jpg")