自动导入和姓名相同名称的照片，谢谢！

zyhui1961

自动导入和姓名相同名称的照片，谢谢！

蓝桥玄霜

图片的例子：

zyhui1961

蓝桥玄霜 发表于 2024-1-12 16:23
图片的例子：

谢谢版主回复，非常感谢！
代码我抄写了，不知道是抄写的不对还是需要简单改一些语句，没能达到我的目的。
老师，我知道你这样发图片而不是直接发代码，是逼着我们学习，可谓用心良苦。
老师，真不是我不想动手，我是小学二年级学历，好多东西真的是很吃力也学不会，
还麻烦老师帮我看一下，万分感谢！！！

cidanji

1. Sub ss()
   
2. Dim r&, c&, ar, i&, sp As Shape, pth$, n&, rg As Range
   
3. With Sheet03
   
4.     '删旧
   
5.     For Each sp In .Shapes
   
6.         c = sp.TopLeftCell.Column
   
7.         If sp.TopLeftCell.Row > 10 And c > 19 And c < 25 Then sp.Delete
   
8.     Next
   
9.     '取数
   
10.     r = .Cells(.Rows.Count, 3).End(3).Row
    
11.     If r < 11 Then Exit Sub '空表退出
    
12.     ar = .Range("B11:x" & r)
    
13.     '加新
    
14.     Application.ScreenUpdating = False
    
15.     For i = 1 To UBound(ar)
    
16.         pth = ThisWorkbook.Path & "\学生照片" & ar(i, 2) & ".jpg"
    
17.         If Dir(pth) <> "" Then
    
18.             Set rg = .Cells(i + 10, (i + 4) Mod 5 + 20).MergeArea
    
19.             With .Pictures.Insert(pth)
    
20.                 .ShapeRange.LockAspectRatio = False
    
21.                 .Width = rg.Width - 6
    
22.                 .Height = rg.Height - 6
    
23.                 .Left = rg.Left + 3
    
24.                 .Top = rg.Top + 3
    
25.             End With
    
26.         End If
    
27.     Next
    
28.     Application.ScreenUpdating = True
    
29. End With
    
30. End Sub

复制代码

gwjkkkkk

感觉设计不大合理，有些难度。。。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar(), i&, p$, f, n&, strFileName$, strExtName$, dic As Object, shp As Shape
   
    p = ThisWorkbook.Path & "\"
    With Application.FileDialog(4)
        .InitialFileName = p
        .AllowMultiSelect = True
        If .Show Then p = .SelectedItems(1) & "\" Else Exit Sub
    End With
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    For Each shp In ActiveSheet.Shapes
        If shp.Type = 11 Then shp.Delete
    Next
    With CreateObject("VBScript.RegExp")
        .Pattern = "jpg|jpep|png|gif|bmp|gif"
        .IgnoreCase = True
        For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(p).Files
            strExtName = Mid(f.Name, InStrRev(f.Name, ".") + 1)
            strFileName = Left(f.Name, InStrRev(f.Name, ".") - 1)
            If .test(strExtName) Then
                dic(strFileName) = f.Path
            End If
        Next
    End With
    With Range("C11", Cells(Rows.Count, "C").End(xlUp))
        ar = .Value
        For i = 1 To UBound(ar)
            If dic.exists(ar(i, 1)) Then
                n = IIf(i Mod 5 = 0, 5, i Mod 5)
                .Cells(i, 17 + n).Select
                ActiveSheet.Pictures.Insert(dic(ar(i, 1))).Select
                With Selection

                    .ShapeRange.LockAspectRatio = msoFalse
                    .Height = ActiveCell.RowHeight * 5
                    .Width = ActiveCell.Width
                    .Placement = xlMoveAndSize
                End With
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

蓝桥玄霜

zyhui1961 发表于 2024-1-12 18:03
谢谢版主回复，非常感谢！
代码我抄写了，不知道是抄写的不对还是需要简单改一些语句，没能达到我的目的 ...

请见附件。

啦啦比比

如果名称我也修改了，但是插入的图片是不对应了

zyhui1961

cidanji 发表于 2024-1-12 19:04

谢谢！
可能是我操作不正确，代码复制了，不能导入电照片。