Cara mudah menanyakan gambar mengikut nama dalam Excel

Artikel ini membawa anda pengetahuan yang berkaitan tentang excel terutamanya mengatur isu berkaitan tentang cara menanyakan gambar mengikut nama, termasuk cara memasukkan gambar dari satu lembaran kerja ke lembaran kerja yang lain dalam lajur A jadual data, sisipan kelompok foto daripada jadual foto ke dalam lajur B jadual data, dsb. Mari kita lihat bersama-sama. Saya harap ia akan membantu semua orang.

Cadangan pembelajaran berkaitan: tutorial cemerlang

Bagaimana untuk memasukkan gambar dari satu lembaran kerja ke lembaran kerja yang lain? Berikan satu contoh.

Seperti yang ditunjukkan di bawah:

Buku kerja mempunyai dua lembaran kerja.

Lembaran kerja tempat foto disimpan dinamakan [Foto], dan lembaran kerja tempat gambar perlu disisipkan dinamakan [Data].

Kini kita perlu memasukkan foto secara berkelompok daripada jadual [Foto] ke dalam lajur B jadual [Data] berdasarkan nama gambar dalam lajur A jadual [data]...

Sampel animasi adalah seperti berikut :

...

Untuk merealisasikan fungsi sedemikian, sebenarnya, 3 baris kod sudah memadai.

Kodnya adalah seperti berikut:

Sub InsertPicFromSheet()
Dim rngData As Range, rngPicName As Range
For Each rngData In Range("a2", Cells(Rows.Count, 1).End(3))
Set rngPicName = Sheets("照片").Cells.Find(rngData.Value, , , xlWhole)
'使用Find方法在照片表完整匹配姓名
If Not rngPicName Is Nothing Then rngPicName.Offset(0, 1).Copy rngData.Offset(0, 1)
'如果有找到对应的姓名，则将照片复制粘贴到目标位置
Next
End Sub

Walau bagaimanapun...

Masalah terbesar dengan kod di atas ialah jadual data tidak memadamkan gambar lama. Jika anda menjalankan program berulang kali, ia akan Ini menyebabkan pengumpulan imej Untuk menyelesaikan masalah ini, kita perlu menambah dua lagi baris kod.

Kod diubah suai seperti berikut:

Sub InsertPicFromSheet()
Dim shp As Shape, rngData As Range, rngPicName As Range
For Each shp In ActiveSheet.Shapes
'删除活动工作表原有照片
If shp.Type = 13 Then shp.Delete
Next
For Each rngData In Range("a2", Cells(Rows.Count, 1).End(3))
Set rngPicName = Sheets("照片").Cells.Find(rngData.Value, , , xlWhole)
'使用Find方法在照片表的完整匹配姓名
If Not rngPicName Is Nothing Then rngPicName.Offset(0, 1).Copy rngData.Offset(0, 1)
'如果有找到对应的姓名，则将照片复制粘贴到目标位置
Next
End Sub

Kod di atas menggunakan pendekatan satu saiz untuk semua untuk memadam imej lama.

Tidak lebih daripada dua...

Walaupun kod ini cukup untuk rakan-rakan yang mempunyai asas VBA yang baik untuk menangani kebanyakan masalah dengan sedikit pengubahsuaian, tetapi untuk pemula, ia jelas Tidak cukup mesra. ..

Contohnya...

1. Nama foto ditetapkan dalam lajur A jadual data, ia mungkin bukan lajur A. Saya betul.

2. Lokasi tempat foto diletakkan di dalam sel di mana lajur nama dialihkan satu lajur ke kanan, sudah tentu, ini mungkin tidak berlaku masih betul.

3. Dalam kod, lembaran kerja yang menyimpan foto ditetapkan pada helaian ("foto"). . Kod tidak ditetapkan Saiz sel disesuaikan dengan saiz gambar, saya...

Kod diubah suai seperti berikut:

Kod di atas selesai tiga masalah biasa yang kami sebutkan tadi...

Sub InsertPicFromSheet2()
'ExcelHome VBA编程学习与实践 by:看见星光
Dim rngData As Range, rngWhere As Range, cll As Range
Dim rngPicName As Range, rngPic As Range, rngPicPaste As Range
Dim shp As Shape, sht As Worksheet, bln As Boolean
Dim strWhere As String, strPicName As String, strPicShtName As String
Dim x, y As Long, lngYesCount As Long, lngNoCount As Long
'On Error Resume Next
Set rngData = Application.InputBox("请选择应插入图片名称的单元格区域", Type:=8)
'用户选择需要插入图片的名称所在单元格范围
Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
'intersect语句避免用户选择整列单元格，造成无谓运算的情况
If rngData Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub
strWhere = InputBox("请输入放置图片偏移的位置，例如上1、下1、左1、右1", , "右1")
'用户输入图片相对单元格的偏移位置
If Len(strWhere) = 0 Then Exit Sub
x = Left(strWhere, 1)
'偏移的方向
If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub
y = Val(Mid(strWhere, 2))
'偏移的值
Select Case x
Case "上"
Set rngWhere = rngData.Offset(-y, 0)
Case "下"
Set rngWhere = rngData.Offset(y, 0)
Case "左"
Set rngWhere = rngData.Offset(0, -y)
Case "右"
Set rngWhere = rngData.Offset(0, y)
End Select
strPicShtName = InputBox("请输入存放图片的工作表名称", , "照片")
For Each sht In Worksheets
If sht.Name = strPicShtName Then bln = True
Next
If bln <> True Then MsgBox "未找到保存图片的工作表：" & strPicShtName & vbCrLf & "程序退出。": Exit Sub
Application.ScreenUpdating = False
rngData.Parent.Select
For Each shp In ActiveSheet.Shapes
&#39;如果旧图片存放在目标图片存放范围则删除
If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete
Next
x = rngWhere.Row - rngData.Row
y = rngWhere.Column - rngData.Column
&#39;偏移的纵横坐标
For Each cll In rngData
&#39;遍历选择区域的每一个单元格
strPicName = cll.Text
&#39;图片名称
If Len(strPicName) Then
&#39;如果单元格存在值
Set rngPicName = Sheets(strPicShtName).Cells.Find(cll.Value, , , xlWhole)
&#39;使用Find方法在照片表完整匹配姓名
If Not rngPicName Is Nothing Then
Set rngPicPaste = cll.Offset(x, y)
&#39;粘贴图片的单元格
Set rngPic = rngPicName.Offset(0, 1)
&#39;保存图片的单元格
lngYesCount = lngYesCount + 1
&#39;累加找到结果的个数
If lngYesCount = 1 Then
&#39;设置放置图片单元格的行高和列宽，以适应图片的大小
rngPicPaste.RowHeight = rngPic.RowHeight
rngPicPaste.ColumnWidth = rngPic.ColumnWidth
End If
rngPicName.Offset(0, 1).Copy rngPicPaste
&#39;如果有找到对应的姓名，则将照片复制粘贴到目标位置
Else
lngNoCount = lngNoCount + 1
&#39;累加未找到结果的个数
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "共处理成功" & lngYesCount & "个对象，另有" & lngNoCount & "个非空单元格未找到对应的图片名称。"
End Sub

Sudah tentu...tiga tetapi bukan semua...

Masih terdapat beberapa masalah yang tidak dapat diselesaikan yang mungkin timbul dalam aplikasi praktikal...

Contohnya...

1. Bagaimana untuk menyelesaikannya Hubungan antara imej dan sumber data? Apabila gambar sumber data berubah, gambar jadual data juga berubah secara automatik? Nah, selain menjalankan semula program, anda juga boleh menggunakan acara pengaktifan lembaran kerja, atau menggunakan activesheet.chartobjects.add...

2. Bagaimana untuk menetapkan saiz gambar agar sesuai sel dan bukannya melaraskan saiz sel Sesuaikan dengan gambar?

Cadangan pembelajaran berkaitan:

tutorial cemerlang

Atas ialah kandungan terperinci Cara mudah menanyakan gambar mengikut nama dalam Excel. Untuk maklumat lanjut, sila ikut artikel berkaitan lain di laman web China PHP!