Excel簡單搞定怎麼按名稱查詢圖片

手機如何做表格：點選檢視

相關學習推薦：

如何將圖片從一張工作表插入到另外一張工作表呢？舉個例子。

如下圖：

一份工作簿有兩張工作表。

存放照片的工作表名為【照片】，需要插入圖片的工作表名為【資料】。

現在需要根據【資料】表的A列的圖片名稱，將【照片】表的照片批次插入到【資料】表的B列中去……

範例動畫如下：

……

實現這樣的功能，其實3句程式碼就夠了。

程式碼如下：

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

不過……

以上程式碼最大的問題在於，沒有刪除資料表原本就有舊圖片，如果重複執行程式，會造成圖片累積，為了解決這個問題，我們需要再加上兩句程式碼。

程式碼修改如下：

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

以上程式碼使用一刀切的方式刪除了舊有的圖片。

二不過……

儘管這段程式碼對於VBA基礎良好的朋友來說，稍微修改下，已經足夠應對大部分的問題，但是，對於小白而言，顯然不夠友好……

比如說……

1、照片的姓名固定在資料表的A列，實際情況，很可能不是A列，我說的對。

2、放置照片的位置固定於姓名列向右移動1列的單元格，實際情況，當然也很可能不是這樣，我說的還是對。

3、程式碼中將儲存照片的工作表固定設定為sheets(「照片」)，實際情況，肯定很可能不是這樣，我英明……

4、程式碼未設定單元格的大小以適應圖片的大小，我……

程式碼修改如下：

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
'如果舊圖片存放在目標圖片存放範圍則刪除
If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete
Next
x = rngWhere.Row - rngData.Row
y = rngWhere.Column - rngData.Column
'偏移的縱橫座標
For Each cll In rngData
'遍歷選擇區域的每一個單元格
strPicName = cll.Text
'圖片名稱
If Len(strPicName) Then
'如果單元格存在值
Set rngPicName = Sheets(strPicShtName).Cells.Find(cll.Value, , , xlWhole)
'使用Find方法在照片表完整匹配姓名
If Not rngPicName Is Nothing Then
Set rngPicPaste = cll.Offset(x, y)
'貼上圖片的單元格
Set rngPic = rngPicName.Offset(0, 1)
'儲存圖片的單元格
lngYesCount = lngYesCount + 1
'累加找到結果的個數
If lngYesCount = 1 Then
'設定放置圖片單元格的行高和列寬，以適應圖片的大小
rngPicPaste.RowHeight = rngPic.RowHeight
rngPicPaste.ColumnWidth = rngPic.ColumnWidth
End If
rngPicName.Offset(0, 1).Copy rngPicPaste
'如果有找到對應的姓名，則將照片複製貼上到目標位置
Else
lngNoCount = lngNoCount + 1
'累加未找到結果的個數
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "共處理成功" & lngYesCount & "個物件，另有" & lngNoCount & "個非空單元格未找到對應的圖片名稱。"
End Sub

以上程式碼解決了我們前面說的常見的三點問題……

然……三不過……

還是有一些實際應用中可能出現的問題未解決……

比如說……

1、如何解決圖片和資料來源的聯動性？當資料來源圖片更改的時候，資料表的圖片也自動更改？嗯，除了重新執行程式，也可以使用工作表的啟用事件，或者是使用activesheet.chartobjects.add……

2、如何設定圖片的大小適應單元格，而不是調整單元格的大小適應圖片？

相關學習推薦：

以上就是Excel簡單搞定怎麼按名稱查詢圖片的詳細內容，更多請關注TW511.COM其它相關文章！