分享一种VBA利用intersect判断Excel中图片位置并引用的方法

TuskAi

经常看到根据Excel中一列的名称引用另一列对应图片的需求
图片为用户手动添加，实际位置可能会跨单元格

如果只是用循环图片对象判断TopLeftCell位置来确认，可能会导致提取错误
所以想到是否可以用判断图片与名称对应的单元格重合的比例来判断

单元格和图片都有Left，Top，Width，Height四个属性，即横坐标，纵坐标，宽度，高度

根据这四个属性可得到四个点的坐标
而单元格可以用range(cells(行1,列1),cells(行2,列2))的形式表示，刚好也需要四个参数

如果用图片和单元格的四个坐标分别表示两个单元格，再用intersect判断
若有交叉值，说明二者重合（也可能只是边界重合，可用重合单元格个数/（图片_单元格数+单元格_单元格数）来判断重合度）
如果重合度大于指定值，则认为图片在对应的单元格中



示例里的代码

1. Sub test()
   
2. 
   
3. Dim d As Object
   
4. Dim rg As Range
   
5. Dim sp As Shape
   
6. 
   
7. Set d = CreateObject("Scripting.dictionary")
   
8. 
   
9. For Each rg In Range("A2:A4") '将名称及对应的单元格存入字典
   
10.     d.Add rg.Value, rg.Offset(0, 1)
    
11. Next rg
    
12. 
    
13. For Each rg In Range("D2:D4") '循环输出区域名称
    
14.     For Each sp In Shapes '循环图片
    
15.         If 获取shape与range的重合度(d(rg.Value), sp, 0.6) = True Then '判断图片与输入区域单元格的重合度是否大于指定值
    
16.             
    
17.             '复制图片至输出单元格
    
18.             sp.Copy
    
19.             rg.Offset(0, 1).Select
    
20.             ActiveSheet.Paste
    
21.             
    
22.             '锁定纵横比，将图片调整到不大于输出单元格
    
23.             Selection.ShapeRange.LockAspectRatio = msoTrue
    
24.             
    
25.             If Selection.Height > rg.Offset(0, 1).Height Then Selection.Height = rg.Offset(0, 1).Height
    
26.             If Selection.Width > rg.Offset(0, 1).Width Then Selection.Width = rg.Offset(0, 1).Width
    
27.             
    
28.             GoTo flag1 '跳出图片循环
    
29.         End If
    
30.     Next sp
    
31. flag1:
    
32. Next rg
    
33. 
    
34. End Sub
    
35. 
    
36. Function 获取shape与range的重合度(rg As Range, sp As Shape, chd As Double) As Boolean
    
37. 
    
38. Dim rg_rg As Range
    
39. Dim rg_sp As Range
    
40. 
    
41. 获取shape与range的重合度 = False
    
42. 
    
43. '将单元格坐标与图片坐标转化为区域
    
44. Set rg_rg = Range(Cells(rg.Top, rg.Left), Cells(rg.Top + rg.Height - 1, rg.Left + rg.Width - 1))
    
45. Set rg_sp = Range(Cells(sp.Top, sp.Left), Cells(sp.Top + sp.Height - 1, sp.Left + sp.Width - 1))
    
46.    
    
47. '判断区域重合度
    
48. If Not Application.Intersect(rg_rg, rg_sp) Is Nothing Then
    
49.     If Application.Intersect(rg_rg, rg_sp).Count / rg_sp.Count >= chd Then
    
50.         获取shape与range的重合度 = True
    
51.     End If
    
52. End If
    
53. 
    
54. End Function

复制代码

附件
VBA利用intersect判断Excel中图片位置并引用.zip (175.23 KB, 下载次数: 33)

2022-12-14 11:56 上传

点击文件名下载附件

四年前发在知乎的文章
https://zhuanlan.zhihu.com/p/36094403
那时失业了，还想靠这招换一份外卖钱，结果没换到，现在又失业了

TuskAi

如果转换后的区域大于Excel的最大行列数会报错
嵌套的循环对比开销也较大
不过使用场景为用户手动添加的图片，数据量不会太多，应该不会有什么问题

morpheus126

本人读代码能力有点差，暂时没读懂。。。是本人问题
不过您这个点很有用，我研究下
谢谢分享

aman1516

你永远无法预想不规范操作/数据有多少种可能，
下图是选择单元格后粘贴的图片，用 TopLeftCell 判断是完全正确的，
但用楼主的方法却无法得以对应图片（图片大小与单元格大小偏差不大的情况下才有用吧）

若图片较大，跨多行多列多个单元格的时候：

如果是这种情形，再加上 TopLeftCell 也不是对应B列对应单元格的时候（TOP、LEFT偏出的），那就更加够你头痛了。
如下图：

结果当然是希望ABC与右边三图片对应，若不手动修正，能有更AI的方法处理吗？

TuskAi

aman1516 发表于 2022-12-14 21:12
你永远无法预想不规范操作/数据有多少种可能，
下图是选择单元格后粘贴的图片，用 TopLeftCell 判断是完全 ...

这种情况建议对制作表格人的人进行教育
另外，我发这个帖子主要是为了分享用intersect转换图片/单元格坐标求交集的思路，不是真的想彻底解决某一类用户不规范的操作

aman1516

TuskAi 发表于 2022-12-14 21:47
这种情况建议对制作表格人的人进行教育
另外，我发这个帖子主要是为了分享用intersect转换图片/单元格坐 ...

哈哈，教育前面必须要加上“批评”两字，外加文档退回重做！

morpheus126

aman1516 发表于 2022-12-14 21:12
你永远无法预想不规范操作/数据有多少种可能，
下图是选择单元格后粘贴的图片，用 TopLeftCell 判断是完全 ...

不要谈AI了，有些情况，连真人去分辨都无法知道那个图片是应该属于哪里的。。。

perfect131

aman1516 发表于 2022-12-14 22:01
哈哈，教育前面必须要加上“批评”两字，外加文档退回重做！

是的 ， BottomRightCell

aman1516

morpheus126 发表于 2022-12-15 07:54
不要谈AI了，有些情况，连真人去分辨都无法知道那个图片是应该属于哪里的。。。

插入图片时，不管手动还是VBA，一概将图片名称改为指定名称，直接按图片名称调用，管你将图片放的满天飞

morpheus126

aman1516 发表于 2022-12-15 14:30
插入图片时，不管手动还是VBA，一概将图片名称改为指定名称，直接按图片名称调用，管你将图片放的满天飞
...

手动加的话还要命名有点强人所难
当然以上观点都是从一般用户体验角度出发，开发的话没那么多逼事