求助帮忙修改excel插图宏

csbadingge

不好意思，写错了字，已经改成 下面一行 单元格

下面这个 功能是“ 选定起始单元格后，按一定行数(1-n)自动往返插入各种格式的图片，
    '并在单元格中写入插入图片的名称。”

能不能改成在插入图片的下面一行单元格插入图片名称，然后接着继续插图，求各位大神帮忙





Sub 单元格自动插入图片()
    '选定起始单元格后，按一定行数(1-n)自动往返插入各种格式的图片，
    '并在单元格中写入插入图片的名称。

    Pf = "ai,"
    Pf = Pf & "bmp,bmz"
    Pf = Pf & "cdr,cgm,"
    Pf = Pf & "dib,dwg,dxf,"
    Pf = Pf & "emf,emz,eps,exf,exif,"
    Pf = Pf & "fpx,"
    Pf = Pf & "gfa,gif,"
    Pf = Pf & "hdr,"
    Pf = Pf & "ico,"
    Pf = Pf & "jfif,jpe,jpeg,jpg,"
    Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"
    Pf = Pf & "raw,rle,"
    Pf = Pf & "svg,"
    Pf = Pf & "tga,tif,tiff,"
    Pf = Pf & "ufo,"
    Pf = Pf & "wdp,wmf,wmz,"
   
    K = InputBox("插入行数，1=按列挿入", "插入行数", 1)
    If K = "" Then Exit Sub
    Dim Rng  As Range: Set Rng = ActiveCell
   
    OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。")
    If OpenFile = False Then
        myDir = ThisWorkbook.Path & "\"
    Else
        myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
    End If
    Filename = Dir(myDir)
   
    Application.ScreenUpdating = False
   
    Do While Filename <> ""
        If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
            Rng.Cells(1 + n \ K, n Mod K + 1).Select
            ActiveCell = Left(Filename, InStrRev(Filename, ".") - 1)
            
            ActiveSheet.Pictures.insert(myDir & Filename).Select
            With Selection
                .Placement = xlMoveAndSize
                .ShapeRange.LockAspectRatio = msoFalse
                .Top = ActiveCell.Top
                .Left = ActiveCell.Left
                .Height = ActiveCell.Height
                .Width = ActiveCell.Width
            End With
            n = n + 1
        End If
        Filename = Dir
    Loop
   
    Application.ScreenUpdating = True
    Rng.Select
End Sub

02761752696

是这个意思吗？看看效果......

1. Sub 单元格自动插入图片XX()
   
2.     '选定起始单元格后，按一定行数(1-n)自动往返插入各种格式的图片，
   
3.     '并在单元格中写入插入图片的名称。
   
4. 
   
5.     Pf = "ai,"
   
6.     Pf = Pf & "bmp,bmz"
   
7.     Pf = Pf & "cdr,cgm,"
   
8.     Pf = Pf & "dib,dwg,dxf,"
   
9.     Pf = Pf & "emf,emz,eps,exf,exif,"
   
10.     Pf = Pf & "fpx,"
    
11.     Pf = Pf & "gfa,gif,"
    
12.     Pf = Pf & "hdr,"
    
13.     Pf = Pf & "ico,"
    
14.     Pf = Pf & "jfif,jpe,jpeg,jpg,"
    
15.     Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"
    
16.     Pf = Pf & "raw,rle,"
    
17.     Pf = Pf & "svg,"
    
18.     Pf = Pf & "tga,tif,tiff,"
    
19.     Pf = Pf & "ufo,"
    
20.     Pf = Pf & "wdp,wmf,wmz,"
    
21.     K = InputBox("插入行数，1=按列挿入", "插入行数", 1)
    
22.     If K = "" Then Exit Sub
    
23.     Dim Rng  As Range: Set Rng = ActiveCell
    
24.     OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "打开目标文件夹后选择任一图片即可指定文件夹。或按取消则会将当前文件所在文件夹认作指定文件夹。")
    
25.     If OpenFile = False Then
    
26.         myDir = ThisWorkbook.Path & ""
    
27.     Else
    
28.         myDir = Left(OpenFile, InStrRev(OpenFile, ""))
    
29.     End If
    
30.     Filename = Dir(myDir)
    
31.     Application.ScreenUpdating = False
    
32.     Do While Filename <> ""
    
33.         If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then
    
34.              Rng.Cells(1 + n \ K * 2, n Mod K * 2 + 1).Select
    
35.              ActiveCell.Offset(0, 1) = Left(Filename, InStrRev(Filename, ".") - 1)
    
36.             ActiveSheet.Pictures.Insert(myDir & Filename).Select
    
37.             With Selection
    
38.                 .Placement = xlMoveAndSize
    
39.                 .ShapeRange.LockAspectRatio = msoFalse
    
40.                 .Top = ActiveCell.Top
    
41.                 .Left = ActiveCell.Left
    
42.                 .Height = ActiveCell.Height
    
43.                 .Width = ActiveCell.Width
    
44.             End With
    
45.             n = n + 2
    
46.         End If
    
47.         Filename = Dir
    
48.     Loop
    
49.     Application.ScreenUpdating = True
    
50.     Rng.Select
    
51. End Sub
    

复制代码

  

02761752696

审核中   先看效果，是这个意思不？

csbadingge

02761752696 发表于 2018-8-31 11:32
审核中   先看效果，是这个意思不？

首先非常感谢您百忙之中抽时间帮我修改，谢谢！ 我的意思是在文件名显示在图片的下面一个单元格，不是在右边。比如a1插图片1，然后在a2插入该图的文件名，接着在b1插图片2，然后在b2插入该图片的文件名，能麻烦再修改一下吗？万分感谢！！

02761752696

csbadingge 发表于 2018-9-1 14:32
首先非常感谢您百忙之中抽时间帮我修改，谢谢！ 我的意思是在文件名显示在图片的下面一个单元格，不是在 ...

你的问题不是下一列吗？
A1   A2   那是下一行好吧........

csbadingge

02761752696 发表于 2018-9-1 17:04
你的问题不是下一列吗？
A1   A2   那是下一行好吧........

晕，那是我写错了，真的不好意思，那下面一行好改吗？！！！！！