请教高手一个问题

jyjfjszx

   跟香川群子老师学习了怎样批量插入图片（http://club.excelhome.net/thread-608962-2-1.html），但还有一些个人的喜好还没有实现，请各位大侠帮忙解决，付酬劳。问题如下：

目的：	文件夹中有图片文件若干，想在 照片工作表 中A列输入文件名，则在B列单元格显示对应的图片(效果如理想工作表)
效果1	单元格要自动适应图片高度（高太小看不到图片，如果通一高度，则有的嫌大有的嫌小）
效果2	在B列单元格图片上方显示文件名
效果3	如果没有对应图片则显示“没有该图片”，如果有则可以替换原来的图片

jyjfjszx

本人QQ619229629

jyjfjszx

本人手机13915180108

jyjfjszx

我的图片的高度都不是一样的

香川群子

效果2： 在B列单元格图片上方显示文件名

…………
这个似乎很没有必要吧。

因为你已经在A列写有文件名了。 B列在标出，不就重复了么？

…………
关键是，一个单元格中，上部写入文件名，下面在贴图片时，图片的高度计算比较麻烦。

香川群子

效果3中，【如果有则可以替换原来的图片】这句话意思不太明白。

其它的都实现了。

1. Sub AutoPicInsert()
   
2.     Application.ScreenUpdating = False
   
3.    
   
4.     PicPath = ThisWorkbook.Path '默认图片和文件放在同一文件夹里。如果不是，请自己修改、指定图片所在文件夹路径。
   
5.    
   
6.     [b1].Select  '默认从B1单元格开始，如果把这一句注释掉，可以从B列任意行开始，向下检查直到A列单元格内容为空
   
7.     r = ActiveCell.Row
   
8.     Do Until ActiveCell.Offset(0, -1) = ""
   
9.         ActiveCell = ActiveCell.Offset(0, -1) 'B列抄写A列图片文件名称。
   
10.         ActiveCell.Font.ColorIndex = 3 'B列字体改红色
    
11.         ActiveCell.VerticalAlignment = xlTop 'B列文字靠上
    
12. 
    
13.         PicName = ActiveCell.Offset(0, -1)
    
14.         On Error Resume Next
    
15.         ActiveSheet.Pictures.Insert(PicPath & "" & PicName & ".jpg").Select '插入图片
    
16.         If Err.Number Then
    
17.             ActiveCell = "没有图片"
    
18.             Err.Clear
    
19.             GoTo Nxt
    
20.         Else
    
21.             With Selection
    
22.                 .Placement = xlMove
    
23.                 .ShapeRange.LockAspectRatio = msoTrue
    
24.                 ActiveCell.RowHeight = .Height + 20 '设置单元格高度+20 (预留文件名高度)
    
25.                 If .Width > ActiveCell.Width Then ActiveCell.ColumnWidth = .Width / 6 '如果图片比现在B列列宽大，则改大
    
26.                 .Top = ActiveCell.Top + 20 '图片顶点位置
    
27.                 .Left = ActiveCell.Left '图片左边位置
    
28.             End With
    
29.         End If
    
30. Nxt:
    
31.         r = r + 1
    
32.         Cells(r, 2).Select
    
33.     Loop
    
34.     Range("A1").Select
    
35.    
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    
38. 
    

复制代码

jyjfjszx

再问香川群子老师，问题见附件。请百忙中给予解答，不胜感谢！

jyjfjszx

{:soso_e163:}

jyjfjszx

{:soso_e163:}老师啊老师，帮帮忙吧,急啊

jyjfjszx

顶起来{:soso_e163:}{:soso_e177:}