当前位置：首页 → 问答吧 → 按列插图片大小如何跟合并单元格的大小？(已解决,尾贴附案例)

按列插图片大小如何跟合并单元格的大小？(已解决,尾贴附案例)

时间：2009-10-09

来源：互联网

隔了几年又找到论坛了，还好用户名没有过期．呵呵！

附件是一段自行按名称搜索并插图片的代码，很好用，几年前我有贴过的．　现请高手帮忙解决新问题．继续完善此代码．

请见附件问题是：　图片大小不能随合并的单元格去变化．单元格合并没有规律，有的是三格，有的是四格，这段代码要怎么改？
谢谢了！
（注：执行宏时会跳出找文件夹的框，　选择图片所在文件夹，选确定即可．　试验时，可以随便用几个图改成我文件里相同名称即可）

Selection.Top = Cells(i, b).Top '设置图片大小
      Selection.Left = Cells(i, b).Left
      Selection.Width = Cells(i, b).Width
      Selection.Height = Cells(i, b).Height

合并后图片大小不适合.rar (236.21 KB)

[ 本帖最后由 TMOY 于 2009-10-13 11:23 编辑 ]

作者: TMOY 发布时间: 2009-10-09

可以用mergearea.rows.count
mergearea.columns.count
来乘一下

作者: lb_bn 发布时间: 2009-10-09

碰到一个问题，您的合并单元中存在重叠的多幅图片，如何解决？？？

作者: smhf_6 发布时间: 2009-10-09

jxb8088老师对图片的VBA编程有独到的技巧，楼主不妨可以问问他

作者: itxianfeng 发布时间: 2009-10-09

'使用前最好先关闭无关的图片，比如自动筛选的图标
' 调整合并单元格的图片大小，基本前提是每个合并单元格中的第一单元格需有一图片，其它各种特殊情况在此尚未考虑
'办法一：先做图片循环，取出图片名称，存入数组，然后做合并单元格循环，依次调整图片，条件是图片不能有多有少，
   '  必须一一对应，且在指定的位置上。这个方法应该是可以的，但取决于楼主的基本资料的合规性
'办法二：双重循环，速度自然要慢点，但条件可适当放宽
Sub xzm()
For i = 4 To 21 '现有图片的合并单元格的起始位置
Set ma = Cells(i, 2).MergeArea
If Cells(i, 2).MergeCells Then
kr = ma.Rows.Count
'ActiveSheet.Shapes("Picture " & s).Select
      For Each pic In ActiveSheet.Shapes
      If pic.Type = msoPicture Then
   '  s = pic.Name
         If Not Application.Intersect(ma, pic.TopLeftCell) Is Nothing Then '
   pic.Select
         Selection.Top = ma.Top '
Selection.Left = ma.Left
         Selection.Width = ma.Width
         Selection.Height = ma.Height
         i = i + kr - 1    '
         Exit For
         End If
      End If
      Next
End If
Next
End Sub

作者: smhf_6 发布时间: 2009-10-09

引用:

原帖由 smhf_6 于 2009-10-9 19:57 发表
碰到一个问题，您的合并单元中存在重叠的多幅图片，如何解决？？？

哦,这是我特意改成这样的.我自己有四个版本的插图代码,分别适合不同的要求.
我看了论坛上有一套简洁的批量插图代码. 对比之下仍然觉得我这套更适合我当前的工作.
1,实际应用时,公司的图片都会专门存放在某电脑的某文件夹, 一般不会同要制作的EXCEL表格在一起. 除非是为了做演示.
2,很多时候,同一款的照片会有正面和背面两张,有时候甚至有侧面等等, 文件名有可能为: A001A和A001B..., 我在表格里插入符合A001名称所有图片,我自定义为模糊插图法. 我另有一套代码则是精确插图,名称要一模一样的图片才会被插入.这只是不同要求而产生的功能.

您看到的重复图片不知道是否我重复运行了宏所产生或是有相同的照片,起了不同的名字,比如服装的返单,可能会用A001,A001a1, A001A2来表示, 这些都会被插入,即使图片是一样的, 但对我还是有用途的,我看到多少张图就知道返单多少次,对我是有用处的. 我刚看了下,多张图片有些是不同颜色搭配的,属于有效插图.

同时谢谢您的指正.

其他两位的回复我要慢慢研究下,欢迎大家继续提供建议. 谢谢.

[ 本帖最后由 TMOY 于 2009-10-10 00:54 编辑 ]

作者: TMOY 发布时间: 2009-10-10

引用:

原帖由 lb_bn 于 2009-10-9 18:22 发表
可以用mergearea.rows.count
mergearea.columns.count
来乘一下

根据提示改成如下，但仍然显示出错，
Selection.Top = Cells(i, b).Top '设置图片大小
      Selection.Left = Cells(i, b).Left
      Selection.Width = Cells(i, b).Width
   x = MergeArea.Rows.Count          合并多少格=X
      Selection.Height = Range("i: i + x").Height    图片高度= 合并后的单元格高度

运行错误“424”，要求对象、
请教哪条语法有问题？

作者: TMOY 发布时间: 2009-10-10

引用:

原帖由 smhf_6 于 2009-10-9 20:46 发表
'使用前最好先关闭无关的图片，比如自动筛选的图标
' 调整合并单元格的图片大小，基本前提是每个合并单元格中的第一单元格需有一图片，其它各种特殊情况在此尚未考虑
'办法一：先做图片循环，取出图片名称，存入数 ...

还没搞懂这批代码怎么用,套入文件中没有反映...刻苦学习中..

作者: TMOY 发布时间: 2009-10-10

5楼的代码是独立的，是对您现有表格的图片的调整
与原代码放在同一模块下，或者不同模块下，都没关系，反正是一个独立的过程

作者: smhf_6 发布时间: 2009-10-10

我也试过，我编的VBA代码只能修正单个单元格内的图片大小与单元格相符，如果单元格合并了，这个代码就失效了，真是郁闷。
除非计算出每组三个单元格的高度，并且计算出单元格高度的合计数，才能解决这个问题。
Selection.Height = Cells(i, b).Height+Cells(i+1, b).Height+Cells(i+2, b).Height

[ 本帖最后由 itxianfeng 于 2009-10-10 22:44 编辑 ]

作者: itxianfeng 发布时间: 2009-10-10

引用:

原帖由 itxianfeng 于 2009-10-10 22:35 发表
我也试过，我编的VBA代码只能修正单个单元格内的图片大小与单元格相符，如果单元格合并了，这个代码就失效了，真是郁闷。
除非计算出每组三个单元格的高度，并且计算出单元格高度的合计数，才能解决这个问题。
...

每组也不一定是3个单元格，我在5楼的代码中，就是将合并单元格作为一个对象，填充图片就行了

作者: smhf_6 发布时间: 2009-10-11

试试看！
Sub jxb8088()
For Each c In ActiveSheet.Pictures
c.Height = c.TopLeftCell.MergeArea.Cells.Height
Next
End Sub

作者: jxb8088 发布时间: 2009-10-11

引用:

原帖由 jxb8088 于 2009-10-11 09:43 发表
试试看！
Sub jxb8088()
For Each c In ActiveSheet.Pictures
c.Height = c.TopLeftCell.MergeArea.Cells.Height
Next
End Sub

厉害，我就猜你能做到，谢谢jxb8088老师

作者: itxianfeng 发布时间: 2009-10-11

引用:

原帖由 itxianfeng 于 2009-10-11 13:51 发表

厉害，我就猜你能做到，谢谢jxb8088老师

过奖了，偶偶想到的！

作者: jxb8088 发布时间: 2009-10-11

引用:

原帖由 jxb8088 于 2009-10-11 09:43 发表
试试看！
Sub jxb8088()
For Each c In ActiveSheet.Pictures
c.Height = c.TopLeftCell.MergeArea.Cells.Height
Next
End Sub

谢就一个字, 感激千万分啊!!!

SMHF-6和JXB8088的代码经过试验都有效果!
SMHF这段代码对一格内有多张图片时只作用于一张图.
而JXB这段代码更简洁及可以把所有插入的图片(包括重复插入的图片)一起调适,因此借用到我的代码里形成一份超级代码,可以插入任何格子大小的图片.
完善版共享如下:

Sub 按列插图-模糊选图-通杀合并单元格() '按指定列的内容插入同名图片对应到右边列,图片大小自动适应单元格大小'

On Error GoTo aa
a = ActiveCell.Column '活动的列'
b = a + 1             '活动列的右边一列'
D = ActiveSheet.Cells(65536, a).End(xlUp).Row '最后一行

'跳出选择文件夹对话框
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
      T = .SelectedItems(1)

End If
End With

For i = 1 To D
n = Cells(i, a) '指定单元格的内容为n

If n = "" Then GoTo aa  '空格时跳到最后

Set fs = Application.FileSearch  '设置模糊搜索文件夹
With fs
.LookIn = T '路径为T
.Filename = n & "*.jpg" '文件名为n或者n+?(字数超过n的也以n为准做搜索)
If .Execute > 0 Then    '开始搜索
      For J = 1 To .FoundFiles.Count
      ActiveSheet.Pictures.Insert(.FoundFiles(J)).Select '符合条件的做插入
      Selection.Top = Cells(i, b).Top '设置图片大小
      Selection.Left = Cells(i, b).Left
      Selection.Width = Cells(i, b).Width
      Selection.Height = Cells(i, b).Height
Next J
End If
End With

aa:
Next

For Each c In ActiveSheet.Pictures
c.Height = c.TopLeftCell.MergeArea.Cells.Height 图片高度=合并后单元格高
Next

End Sub

[ 本帖最后由 TMOY 于 2009-10-12 10:23 编辑 ]

作者: TMOY 发布时间: 2009-10-11

TMOY 朋友光看代码不过瘾，不妨做个简单的演示附件，拿出来晒晒，我认为代码的实际用途至关重要，学而无用那就太可惜了，让大家都分享一下你的成果。
既然你好久不来了应该给大家带来一份惊喜，从时间上看，你已经算是我们的前辈了，希望常回家看看。

既然牵扯到工作簿以外的图片，建议做个文件夹，放入10张图片及其操做的EXCEL表，存放路径就是在桌面上

[ 本帖最后由 itxianfeng 于 2009-10-11 21:32 编辑 ]

作者: itxianfeng 发布时间: 2009-10-11

好的，我还在试用中，昨天在家里因缺乏复杂条件的数据，只是简单的试验代码是否会出错。此点已经求证。
现在工作中实战，目前已经发现有BUG,
1，上述调图代码我重新放置了代码的位置，原位置会导致速度很慢。  我测试过同一文件，改良后速度只要13秒，之前的位置则要1.5分钟以上。
2，另发现一处问题，还没有解决.  如果款号是:018这种文本名称, 插图时会把018, W018, P018等很多不相关的图片插入. 待解决.

最终完善了我会再上传案例的.

另称前辈是折杀我也! 切勿再羞辱我啊..
我只是注册得早些(好像是03年左右), 工作原因需要此份表格,所以当时请教了LONG III等高手, 专心拼凑了一份代码自己能用而已.    其他VBA知识还很少很少, 真的!
本论坛高手如云,我得到过很多帮助, 现在我又回来学习啦....
也希望和大家一起进步.

作者: TMOY 发布时间: 2009-10-12

TMOY 注册时间2005-11-15
也算元老了，不知除了论坛创办者外，最早注册，并且还在论坛的是谁？

作者: 好001 发布时间: 2009-10-12

文件太大了贴不了, 现在看看行不行?

[ 本帖最后由 TMOY 于 2009-10-13 12:04 编辑 ]