按名稱查詢圖片，幾句代碼就搞定

按名稱查詢圖片，幾句代碼就搞定

如何將圖片從一張工作表插入到另外一張工作表呢？舉個(gè)例子。如下圖：

不過(guò)……以上代碼最大的問(wèn)題在于，沒(méi)有刪除數(shù)據(jù)表原本就有舊圖片，如果重復(fù)運(yùn)行程序，會(huì)造成圖片累積，為了解決這個(gè)問(wèn)題，我們需要再加上兩句代碼。

代碼修改如下：Sub InsertPicFromSheet()Dim shp As Shape, rngData As Range, rngPicName As RangeFor Each shp In ActiveSheet.Shapes'刪除活動(dòng)工作表原有照片If shp.Type = 13 Then shp.DeleteNextFor 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)'如果有找到對(duì)應(yīng)的姓名，則將照片復(fù)制粘貼到目標(biāo)位置NextEnd Sub

以上代碼使用一刀切的方式刪除了舊有的圖片。二不過(guò)……盡管這段代碼對(duì)于VBA基礎(chǔ)良好的朋友來(lái)說(shuō)，稍微修改下，已經(jīng)足夠應(yīng)對(duì)大部分的問(wèn)題，但是，對(duì)于小白而言，顯然不夠友好……比如說(shuō)……1、照片的姓名固定在數(shù)據(jù)表的A列，實(shí)際情況，很可能不是A列，我說(shuō)的對(duì)。2、放置照片的位置固定于姓名列向右移動(dòng)1列的單元格，實(shí)際情況，當(dāng)然也很可能不是這樣，我說(shuō)的還是對(duì)。3、代碼中將儲(chǔ)存照片的工作表固定設(shè)置為sheets(“照片”)，實(shí)際情況，肯定很可能不是這樣，我英明……4、代碼未設(shè)置單元格的大小以適應(yīng)圖片的大小，我……圖片

代碼修改如下：Sub InsertPicFromSheet2()'ExcelHome VBA編程學(xué)習(xí)與實(shí)踐 by:看見(jiàn)星光Dim rngData As Range, rngWhere As Range, cll As RangeDim rngPicName As Range, rngPic As Range, rngPicPaste As RangeDim shp As Shape, sht As Worksheet, bln As BooleanDim strWhere As String, strPicName As String, strPicShtName As StringDim x, y As Long, lngYesCount As Long, lngNoCount As Long'On Error Resume NextSet rngData = Application.InputBox("請(qǐng)選擇應(yīng)插入圖片名稱的單元格區(qū)域", Type:=8)'用戶選擇需要插入圖片的名稱所在單元格范圍Set rngData = Intersect(rngData.Parent.UsedRange, rngData)'intersect語(yǔ)句避免用戶選擇整列單元格，造成無(wú)謂運(yùn)算的情況If rngData Is Nothing Then MsgBox "選擇的單元格范圍不存在數(shù)據(jù)！": Exit SubstrWhere = InputBox("請(qǐng)輸入放置圖片偏移的位置，例如上1、下1、左1、右1", , "右1")'用戶輸入圖片相對(duì)單元格的偏移位置If Len(strWhere) = 0 Then Exit Subx = Left(strWhere, 1)'偏移的方向If InStr("上下左右", x) = 0 Then MsgBox "你未輸入偏移方位。": Exit Suby = Val(Mid(strWhere, 2))'偏移的值Select Case xCase "上"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 SelectstrPicShtName = InputBox("請(qǐng)輸入存放圖片的工作表名稱", , "照片")For Each sht In WorksheetsIf sht.Name = strPicShtName Then bln = TrueNextIf bln <> True Then MsgBox "未找到保存圖片的工作表：" & strPicShtName & vbCrLf & "程序退出。": Exit SubApplication.ScreenUpdating = FalserngData.Parent.SelectFor Each shp In ActiveSheet.Shapes'如果舊圖片存放在目標(biāo)圖片存放范圍則刪除If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.DeleteNextx = rngWhere.Row - rngData.Rowy = rngWhere.Column - rngData.Column'偏移的縱橫坐標(biāo)For Each cll In rngData'遍歷選擇區(qū)域的每一個(gè)單元格strPicName = cll.Text'圖片名稱If Len(strPicName) Then'如果單元格存在值Set rngPicName = Sheets(strPicShtName).Cells.Find(cll.Value, , , xlWhole)'使用Find方法在照片表完整匹配姓名If Not rngPicName Is Nothing ThenSet rngPicPaste = cll.Offset(x, y)'粘貼圖片的單元格Set rngPic = rngPicName.Offset(0, 1)'保存圖片的單元格lngYesCount = lngYesCount + 1'累加找到結(jié)果的個(gè)數(shù)If lngYesCount = 1 Then'設(shè)置放置圖片單元格的行高和列寬，以適應(yīng)圖片的大小rngPicPaste.RowHeight = rngPic.RowHeightrngPicPaste.ColumnWidth = rngPic.ColumnWidthEnd IfrngPicName.Offset(0, 1).Copy rngPicPaste'如果有找到對(duì)應(yīng)的姓名，則將照片復(fù)制粘貼到目標(biāo)位置ElselngNoCount = lngNoCount + 1'累加未找到結(jié)果的個(gè)數(shù)End IfEnd IfNextApplication.ScreenUpdating = TrueMsgBox "共處理成功" & lngYesCount & "個(gè)對(duì)象，另有" & lngNoCount & "個(gè)非空單元格未找到對(duì)應(yīng)的圖片名稱。"End Sub以上代碼解決了我們前面說(shuō)的常見(jiàn)的三點(diǎn)問(wèn)題……

版權(quán)聲明：本文內(nèi)容由網(wǎng)絡(luò)用戶投稿，版權(quán)歸原作者所有，本站不擁有其著作權(quán)，亦不承擔(dān)相應(yīng)法律責(zé)任。如果您發(fā)現(xiàn)本站中有涉嫌抄襲或描述失實(shí)的內(nèi)容，請(qǐng)聯(lián)系我們jiasou666@gmail.com 處理，核實(shí)后本網(wǎng)站將在24小時(shí)內(nèi)刪除侵權(quán)內(nèi)容。

版權(quán)聲明：本文內(nèi)容由網(wǎng)絡(luò)用戶投稿，版權(quán)歸原作者所有，本站不擁有其著作權(quán)，亦不承擔(dān)相應(yīng)法律責(zé)任。如果您發(fā)現(xiàn)本站中有涉嫌抄襲或描述失實(shí)的內(nèi)容，請(qǐng)聯(lián)系我們jiasou666@gmail.com 處理，核實(shí)后本網(wǎng)站將在24小時(shí)內(nèi)刪除侵權(quán)內(nèi)容。