设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 用VBA,2007图片插入求解
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1926|回复: 8

[已解决]用VBA,2007图片插入求解

[复制链接]
发表于 2011-8-18 17:38 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
在论坛找了一位老师的宏在2003中可以用但在2007中无法用请老师修改一下
最佳答案
月排行榜 / 总排行榜
zjdh
2011-8-18 19:00
本帖最后由 zjdh 于 2011-8-18 19:02 编辑
  1. Sub 查找()
  2.     Dim Fn As String
  3.     On Error Resume Next
  4.     Application.ScreenUpdating = False
  5.     Application.EnableEvents = False
  6.     If Sheets("录入表 (2)").Range("C2") = "" Then
  7.         MsgBox ("没有可用数据")
  8.     End If
  9.     If Sheets("录入表 (2)").Range("C2") <> "" Then
  10.         With Sheets("录入表 (2)")
  11.             .Pictures(1).Delete
  12.             .Range("C5").Select
  13.             Fn = Dir(ThisWorkbook.Path & "\照片\*.jpg")
  14.             Do While Fn <> ""
  15.                 If Fn Like .Range("C2").Value & "*" Then Exit Do
  16.                 Fn = Dir
  17.             Loop
  18.             If Fn = "" Then
  19.                 Exit Sub
  20.             Else
  21.                 .Pictures.Insert ThisWorkbook.Path & "\照片" & Fn
  22.                 .Pictures(1).Left = Range("$C$5").Left
  23.                 .Pictures(1).Top = Range("$C$5").Top
  24.                 .Pictures(1).ShapeRange.LockAspectRatio = False
  25.                 .Pictures(1).Height = Range("$C$5").Height * 6
  26.                 .Pictures(1).Width = Range("$C$5").Width * 3
  27.             End If
  28.         End With
  29.         Application.EnableEvents = True
  30.         Application.ScreenUpdating = True
  31.     End If
  32. End Sub
复制代码

2007图片插入求解.rar

61.8 KB, 下载次数: 8
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
zjdh
发表于 2011-8-18 18:20 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 zjdh 于 2011-8-18 18:21 编辑

  2. Sub 查找()
  3.     Dim Fn As String
  4.     On Error Resume Next
  5.     Application.ScreenUpdating = False
  6.     Application.EnableEvents = False
  7.     If Sheets("录入表 (2)").Range("C2") = "" Then
  8.         MsgBox ("没有可用数据")
  9.     End If
  10.     If Sheets("录入表 (2)").Range("C2") <> "" Then
  11.         With Sheets("录入表 (2)")
  12.             .Pictures(1).Delete
  13.             .Range("C5").Select
  14.             Fn = Dir(ThisWorkbook.Path & "\照片\*.jpg")
  15.             Do While Fn <> ""
  16.                 If Fn Like .Range("C2").Value & "*" Then Exit Do   
  17.                 Fn = Dir
  18.             Loop
  19.             L = Range("$C$5").Left
  20.             T = Range("$C$5").Top
  21.             If Fn = "" Then
  22.                 Exit Sub
  23.             Else
  24.                 .Pictures.Insert ThisWorkbook.Path & "\照片" & Fn
  25.                 .Pictures.Left = L
  26.                 .Pictures.Top = T
  27.                 .Pictures.Height = Range("$C$5").Height * 6
  28.                 .Pictures.Width = Range("$C$5").Width * 3  
  29.             End If
  30.         End With
  31.         Application.EnableEvents = True
  32.         Application.ScreenUpdating = True
  33.     End If
  34. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2011-8-18 18:35 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
回复 zjdh 的帖子

zjdh老师，测试了下，左、右、上都符合要求，就是下边太长了，没在指定的单元格区域内
回复

使用道具 举报

 楼主| 发表于 2011-8-18 18:39 | 显示全部楼层
再传附件用的是ZJDH老师的代码

2007图片插入求解1.rar

80.08 KB, 下载次数: 13
回复

使用道具 举报

zjdh
发表于 2011-8-18 19:00 | 显示全部楼层    本楼为最佳答案   
本帖最后由 zjdh 于 2011-8-18 19:02 编辑
  1. Sub 查找()
  2.     Dim Fn As String
  3.     On Error Resume Next
  4.     Application.ScreenUpdating = False
  5.     Application.EnableEvents = False
  6.     If Sheets("录入表 (2)").Range("C2") = "" Then
  7.         MsgBox ("没有可用数据")
  8.     End If
  9.     If Sheets("录入表 (2)").Range("C2") <> "" Then
  10.         With Sheets("录入表 (2)")
  11.             .Pictures(1).Delete
  12.             .Range("C5").Select
  13.             Fn = Dir(ThisWorkbook.Path & "\照片\*.jpg")
  14.             Do While Fn <> ""
  15.                 If Fn Like .Range("C2").Value & "*" Then Exit Do
  16.                 Fn = Dir
  17.             Loop
  18.             If Fn = "" Then
  19.                 Exit Sub
  20.             Else
  21.                 .Pictures.Insert ThisWorkbook.Path & "\照片" & Fn
  22.                 .Pictures(1).Left = Range("$C$5").Left
  23.                 .Pictures(1).Top = Range("$C$5").Top
  24.                 .Pictures(1).ShapeRange.LockAspectRatio = False
  25.                 .Pictures(1).Height = Range("$C$5").Height * 6
  26.                 .Pictures(1).Width = Range("$C$5").Width * 3
  27.             End If
  28.         End With
  29.         Application.EnableEvents = True
  30.         Application.ScreenUpdating = True
  31.     End If
  32. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2011-8-18 19:05 | 显示全部楼层
回复 zjdh 的帖子

谢谢ZJDH老师，你的技术真高，良师
回复

使用道具 举报

zjdh
发表于 2011-8-18 19:13 | 显示全部楼层
本帖最后由 zjdh 于 2011-8-18 19:14 编辑

其实可以简化：

  2. Sub 查找()
  3.     Dim Fn As String
  4.     On Error Resume Next
  5.     If Sheets("录入表 (2)").Range("C2") = "" Then MsgBox ("没有可用数据"): Exit Sub
  6.     With Sheets("录入表 (2)")
  7.         .Pictures(1).Delete
  8.         Fn = Dir(ThisWorkbook.Path & "\照片\*.jpg")
  9.         Do While Fn <> ""
  10.             If Fn Like .Range("C2").Value & "*" Then Exit Do
  11.             Fn = Dir
  12.         Loop
  13.         If Fn = "" Then Exit Sub
  14.         .Pictures.Insert ThisWorkbook.Path & "\照片" & Fn
  15.         .Pictures(1).Left = Range("$C$5").Left
  16.         .Pictures(1).Top = Range("$C$5").Top
  17.         .Pictures(1).ShapeRange.LockAspectRatio = False
  18.         .Pictures(1).Height = Range("$C$5").Height * 6
  19.         .Pictures(1).Width = Range("$C$5").Width * 3
  20.     End With
  21. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2011-8-18 19:24 | 显示全部楼层
回复 zjdh 的帖子

zjdh老师，测试了好用，谢谢谢谢
回复

使用道具 举报

发表于 2012-3-17 21:36 | 显示全部楼层
学习！！！！！！！！！！！！！
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 18:45 , Processed in 0.318825 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表