Chèn ảnh tự động bằng VBA

5/5 - (1 bình chọn)

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:

chèn ảnh excel

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:

chèn ảnh excel

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!

Leave a Reply