Hướng dẫn chèn ảnh tự động cho Excel bằng VBA, chi tiết và đơn giản nhất.
Đặc biệt, bạn hoàn toàn có thể chèn hình từ các file ảnh có sẵn trên máy tính hoặc các link ảnh trực tuyến.
Kết quả sau khi chèn ảnh
Hãy xem kết quả sau:

Tuấn sẽ hướng dẫn các bạn chèn ảnh vào file Excel gọn gàng, không méo mó như các hướng dẫn khác trên Internet.
Bắt đầu nhé!
Chuẩn bị
Đầu tiên bạn hãy chuẩn bị một folder hình lưu sẵn trên máy, hoặc danh sách các liên kết dẫn đến hình ảnh bạn muốn chèn.
Tiếp theo hãy chèn thêm vào file Excel của bạn 2 cột là Link hình ảnh và cột Trạng thái để theo dõi quá trình chèn hình.

Ở ví dụ này Tuấn sẽ chèn trực tiếp từ liên kết dẫn đến hình ảnh từ Internet nhé.
Tiến hành
Các bạn truy cập vào VBA từ Excel qua thanh Ribbon ở thẻ Developer hoặc phím tắt ALT + F11.
Tạo thêm 01 module mới và chèn đoạn code bên dưới vào, sau đó đóng cửa sổ VBA.
'TODO: Automatically add image to the cell
'Using: insertImage(Destination, Image Path)
Option Explicit
Function insertImage(dest As Range, imgPath As Range) As String
InsertPicture imgPath, dest, True
If isContainedImage(dest) Then
insertImage = "OK!"
Exit Function
End If
insertImage = "Failed!"
End Function
Private Function AutoPicture(rPath As Range)
Dim ca As Range
Application.Volatile
Set ca = Application.Caller
AutoPicture = InsertPicture(rPath, Application.Caller, False)
End Function
Private Sub ClearPicture(rrg As Range, isSubCall As Boolean)
Dim Ws As Worksheet
Dim pPics As Pictures
Dim pPic As Picture
On Error Resume Next
Set Ws = rrg.Worksheet
If isSubCall = True Then
Set pPics = Ws.Pictures
For Each pPic In pPics
If Not (Application.Intersect(rrg, pPic.TopLeftCell) Is Nothing) Then
If Not (Application.Intersect(rrg, pPic.BottomRightCell) Is Nothing) Then
pPic.Delete
End If
End If
Next
Else
Dim rIndex As Range
For Each rIndex In rrg
Set pPic = Ws.Shapes(rIndex)
pPic.Delete
Next
End If
End Sub
Private Function InsertPicture(rS As Range, rD As Range, Optional isSubCall As Boolean = True)
Dim lRows As Long
Dim lCols As Long
Dim lRow As Long
Dim lCol As Long
Dim rrg As Range
Dim Pic As Shape
Dim Ws As Worksheet
Set Ws = rD.Worksheet
lRows = rS.Rows.Count
lCols = rD.Columns.Count
If rS.Rows.Count <> rD.Rows.Count Or rS.Columns.Count <> rD.Columns.Count Then InsertPicture = CVErr(xlErrNA): Exit Function
On Error Resume Next
ClearPicture rD, True
Dim vKQ() As Variant
ReDim vKQ(1 To lRows, 1 To lCols) As Variant
For lRow = 1 To lRows
For lCol = 1 To lCols
Set rrg = rD(lRow, lCol)
Err.Clear
Set Pic = Ws.Shapes.AddPicture(rS(lRow, lCol), msoFalse, msoTrue, 1, 1, -1, -1)
If Err.Number <> 0 Then
vKQ(lRow, lCol) = CVErr(xlErrNA)
Else
vKQ(lRow, lCol) = Pic.Name
Pic.Placement = xlMoveAndSize
ReSizeShape Pic, rrg
End If
Next
Next lRow
InsertPicture = vKQ
End Function
Private Sub ReSizeShape(a As Shape, rrg As Range)
Dim shr As Single
Dim swr As Single
Dim sha As Single
Dim swa As Single
Dim sTyLe As Single
a.LockAspectRatio = msoFalse
a.ScaleHeight 1, msoTrue, msoScaleFromMiddle
a.ScaleWidth 1, msoTrue, msoScaleFromMiddle
shr = rrg.MergeArea.Height
swr = rrg.MergeArea.Width
sha = a.Height
swa = a.Width
sTyLe = 10
If (shr / swr) >= (sha / swa) Then
a.Width = swr * (100 - sTyLe) / 100
a.Height = (a.Width * sha) / swa
Else
a.Height = shr * (100 - sTyLe) / 100
a.Width = (a.Height * swa) / sha
End If
a.Left = rrg.Left + (swr - a.Width) / 2
a.Top = rrg.Top + (shr - a.Height) / 2
a.LockAspectRatio = msoTrue
End Sub
Function isContainedImage(r As Range) As Boolean
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell = r Then
isContainedImage = True
Else
isContainedImage = False
End If
Next wShape
End Function
Quay trở lại bảng tính, ở ô D3, bạn nhập công thức sau:
=insertImage(A3, C3)
Trong đó,
- A3: là ô bạn sẽ chứa ảnh
- C3: chứa liên kết đến ảnh
Lưu ý: đổi với các bạn chèn ảnh từ Folder trên máy tính, đường dẫn của bạn sẽ có dạng sau:
C:\Users\yourpc\Downloads\Picture01.jpg
Hãy lưu tên ảnh trùng với mã sản phẩm để dễ phân biệt nhé.
Sau khi nhấn Enter, bạn sẽ được kết quả sau:

Nếu liên kết bị lỗi, bạn sẽ nhận được kết quả là Failed! nhé.
Sau đó bạn hãy flash fill xuống các ô còn lại để được kết quả như đầu bài viết nha.
Lưu ý:
Sau khi flash fill xong, bạn hãy dùng tổ hợp phím Shift + F10 + V để dán giá trị, để tránh công thức chạy lại, sẽ tốn tài nguyên và thời gian nếu bạn chèn nhiều hình ảnh.
Code không hoạt động trên phiên bản Excel 2016, bạn có thể sử dụng tốt trên Excel 2013 / 2019 / 2021 và Excel 365.
Phía trên là bài viết giới thiệu cũng như hướng dẫn bạn chèn ảnh vào Excel bằng VBA.
Chúc bạn áp dụng thành công vào công việc hoặc học tập!

Nối các sheet lại với nhau bằng VBA
Hướng dẫn nối các sheet Excel có các cột giống nhau lại thành một bằng VBA

Tạo hiệu ứng tuyết rơi với HTML và CSS
Cùng Tuấn trang trí blog của bạn với hiệu ứng tuyết rơi đón mùa Noel sắp đến nhé.

Chèn ảnh tự động bằng VBA
Hướng dẫn chèn ảnh tự động cho Excel bằng VBA, chi tiết và đơn giản nhất.