ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 157|回复: 12
打印 上一主题 下一主题

[求助] 把F列的照片导出来以B列对应的名称命名

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2018-1-13 13:20 | 只看该作者 |只看大图 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 秋天的芒果 于 2018-1-13 13:27 编辑

路过的大神们求助,把F列的照片导出来并以B列对应的名称命名,图片格式要求为JPEG格式,因为我的实际表行数比较多,压缩包里只是一个例表部分行,数,无论是实表还是例表都有可能遇到没有名称或没有图片的空行问题,如果遇到这样的问题就直接忽略,进行下一行,请各位大神各显神通帮我编写VBA提高工作效率(最好能注解一下方便我学习,以后帮助更多的人)
照片.rar 1.87 MB, 下载次数: 11
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏2 分享分享 有用有用 无用无用
TA的精华主题TA的得分主题
2
发表于 2018-1-13 13:54 | 只看该作者
有的单元格中有两个图片                                                                     .
TA的精华主题TA的得分主题
3
 楼主| 发表于 2018-1-13 14:16 | 只看该作者 |楼主
小花鹿 发表于 2018-1-13 13:54
有的单元格中有两个图片                                                                     .

您好,老师!可能是多放了两个,就默认一个就好了,谢谢!
TA的精华主题TA的得分主题
4
发表于 2018-1-13 14:38 | 只看该作者
秋天的芒果 发表于 2018-1-13 14:16
您好,老师!可能是多放了两个,就默认一个就好了,谢谢!

试试:
  • Sub dt()
  • Application.EnableEvents = False
  • Dim shap As Shape, sn As String
  • Dim i As Integer
  • With ActiveSheet
  •     For i = 1 To .Shapes.Count
  •         Set shap = .Shapes(i)
  •         sn = shap.TopLeftCell.Offset(0, -4).Value
  •         shap.Copy
  •     With .ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart
  •         .Paste
  •         .Export ThisWorkbook.Path & "" & sn & ".jpg"
  •         .Parent.Delete
  •     End With
  •     Next
  • End With
  • Application.EnableEvents = True
  • End Sub
  • 复制代码
    TA的精华主题TA的得分主题
    5
    发表于 2018-1-13 14:40 | 只看该作者
    秋天的芒果 发表于 2018-1-13 14:16
    您好,老师!可能是多放了两个,就默认一个就好了,谢谢!

    Sub lqxs()
        Dim ad$, m&, mc$, shp As Shape
        Dim nm$, n&, myFolder$
        Sheet1.Activate
        n = 0
        myFolder = ThisWorkbook.Path & "\图片"     '指定文件夹名称
        For Each shp In ActiveSheet.Shapes
            If shp.Type = 13 Then
                If Len(Dir(myFolder, vbDirectory)) = 0 Then
                    MkDir myFolder
                End If
                n = n + 1
                ad = shp.TopLeftCell.Address
                m = shp.TopLeftCell.Row
                mc = Cells(m, 2).Value
                nm = mc & "-" & Format(n, "00") & ".jpg"
                shp.CopyPicture
                With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                    .Paste
                    .Export myFolder & nm, "JPG"
                    .Parent.Delete
                End With
                Range(ad) = nm: shp.Delete
            End If
        Next
    End Sub
    TA的精华主题TA的得分主题
    6
    发表于 2018-1-13 14:41 | 只看该作者
    见附件: 照片.rar (1.87 MB, 下载次数: 10)
    TA的精华主题TA的得分主题
    7
    发表于 2018-1-13 15:10 | 只看该作者
    'office2010 (我用2016版试的不成功,换2010就正常)
    Option Explicit

    Sub test()
      Dim shp As Shape, dic, t, row, i, filename, cht
      Set dic = CreateObject("scripting.dictionary")
      With Sheets("sheet1")
        row = .Cells(Rows.Count, "b").End(xlUp).row
        For Each shp In .Shapes
          If shp.Type = 13 Then
            For i = 2 To row
              If .Cells(i, "b").Top <= shp.Top And .Cells(i, "b").Height _
              + .Cells(i, "b").Top > shp.Top And Len(.Cells(i, "b")) > 0 Then Exit For
            Next
            If i < row + 1 Then
              t = .Cells(i, "b")
              dic(t) = dic(t) + 1
              filename = "c:\" & t & "-" & dic(t) & ".jpg"
              shp.CopyPicture
              With .ChartObjects.Add(0, 0, shp.Width, shp.Height)
                .Chart.Paste
                .Chart.Export filename, "JPG"
                .Delete
              End With
            End If
          End If
        Next
      End With
    End Sub
    TA的精华主题TA的得分主题
    8
     楼主| 发表于 2018-1-13 15:17 | 只看该作者 |楼主
    本帖最后由 秋天的芒果 于 2018-1-13 15:26 编辑
    'Option Explicit

    Sub 批量插入批注图片()
        On Error Resume Next
        For i = 2 To [B65536].End(xlUp).Row
            With Range("b" & i)
                .AddComment
                .Comment.Visible = False
                .Comment.Text Text:=""
                .Comment.Shape.Fill.UserPicture (ThisWorkbook.Path & "\图片\" & Trim(Range("b" & i)) & ".jpeg")
                .Comment.Shape.Width = 60
                .Comment.Shape.Height = 70
            End With
        Next
    End Sub
    老师我批量插入批注图片就会很模糊,能不能帮我修改一下这段VBA,默认图片最佳大小比例。

    TA的精华主题TA的得分主题
    9
     楼主| 发表于 2018-1-13 15:29 | 只看该作者 |楼主

    'Option Explicit

    Sub 批量插入批注图片()
        On Error Resume Next
        For i = 2 To [B65536].End(xlUp).Row
            With Range("b" & i)
                .AddComment
                .Comment.Visible = False
                .Comment.Text Text:=""
                .Comment.Shape.Fill.UserPicture (ThisWorkbook.Path & "\图片\" & Trim(Range("b" & i)) & ".jpeg")
                .Comment.Shape.Width = 60
                .Comment.Shape.Height = 70
            End With
        Next
    End Sub
    老师我以上就一段批量插入批注的VBA,但是批量插入后图片很模糊,麻烦帮我修改一下这段VBA,批量插入图片显示最佳的大小比例。谢谢
    TA的精华主题TA的得分主题
    10
    发表于 2018-1-13 23:38 | 只看该作者
    秋天的芒果 发表于 2018-1-13 15:29
    'Option Explicit

    Sub 批量插入批注图片()

    若你原图尺寸小于60*70,则会拉伸图片,当然不清楚了,
    将批注框的宽、高设置代码注释掉:
    ''.Comment.Shape.Width = 60
    ''.Comment.Shape.Height = 70
    改成自动大小:
    .Comment.Shape.TextFrame.AutoSize = True
    将按原图尺寸大小显示,若还不清楚,那就是原图问题了
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

    最新热点上一条 /1 下一条

    关注官方微信,每天坐享新鲜教程
    手机版|关于我们|联系我们|ExcelHome    GMT+8, 2018-1-18 19:42 , Processed in 0.073900 second(s), 11 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优