Help! Cải tiến code VBA chèn hình vào file Excel

Liên hệ QC
Z

zukura

Thành viên mới
Tham gia
18/10/13
Bài viết
8
Được thích
1
Cả nhà giúp em với.

Vấn đề của em là khi có 1 cột mã hàng, thì excel sẽ tự chèn ảnh có sẵn (trong thư mục cố định, tên file là tên của mã hàng) vào cột bên cạnh.

Trước đó em có xài cách của 1 bác khác là viết 1 hàm riêng cho file excel đó, hàm compic(đường dẫn hình). Là dạng chèn hình vào comment. Nhưng do lúc chạy rất hay bị văng ra nên không được tiện lắm.

Hôm qua em mò trên mạng được code VBA của 1 bác về chèn hình vào excel sau khi ta gõ mã của hình đó.
Thấy code của bác này chạy rất nhẹ nhàng và chèn trực tiếp (chứ không phải comment), nên em rất thích.
Nhưng chưa đủ áp dụng vào công việc của em, nhờ các bác cao thủ giúp em với ạ:
- File đính kèm đã có code chạy cho cột mã 1
- Nếu em có thêm cột mã 2 thì code sẽ viết như thế nào? (Nếu dạng hàm thì quá dễ, hàm ở đâu hình sẽ hiện ở đó)
- Cột mã nếu là công thức hoặc khi copy dán thì code không chạy (cả ngàn mã không thể gõ tay rồi enter được) -> lỗi type miss match
- Nếu trong 10 mã mà có 5 mã bị sai, bỏ trống -> 5 mã còn lại vẫn hiện hình, 5 mã kia không hiện (đằng này báo lỗi và ko hiện tất)

Giúp em với nha.
 

File đính kèm

  • Cach chen hinh vao excel.rar
    28.4 KB · Đọc: 230
Sắp xếp theo thời gian sắp xếp theo bầu chọn
batman1 đã viết:
Nếu cột Mã dùng công thức thì khi công thức phải tính lại do tham chiếu thay đổi thì sự kiện Change không sảy ra nên code sẽ không được thực hiện. Và kết quả là ảnh không được đổi.

Code dưới đây cho phép dán hàng loạt Mã.
-------------
Trước hết về sub tổng quát InsertPicture. Bạn có thể lưu Module cùng với InsertPicture vào "thư viện" - một thư mực nào đó, để khi cần thì chỉ (trong VBE): File -> Import File -> duyệt tới tập tin BAS đã lưu -> chọn tập tin BAS để thêm vào tập tin Excel hiện hành -> dùng Sub InsertPicture trong tập tin hiện hành.

Bạn không nên dùng Pictures vì đôi khi gặp những lỗi khó hiểu.

InsertPicture có nhiều tùy chọn: có thể nhập ảnh vào 1 ô hoặc vùng nhiều ô mà không cần merge cells, nhập ảnh với kích thước thực, nhập ảnh center trong ô/vùng hoặc vừa khít, nhập ảnh nhưng khi mang sang máy khác thì phải mang ảnh theo hoặc nhập ảnh vĩnh viễn vào sheet để khi mang sang máy khác thì không phải mang ảnh đi theo.

Tôi nhìn tập tin của bạn thì thấy bạn muốn nhập ảnh vừa khít với vùng (ảnh sẽ bị biến dạng nếu tỉ lệ cao/rộng của vùng <> cao/rộng của ảnh).
Code
Mã: 
Private Sub Worksheet_Change(ByVal Target As range)
Dim rng As range
    If Intersect(Target, Union([A2:A10000], [D2:D10000])) Is Nothing Then Exit Sub
    For Each rng In Target
        InsertPicture ThisWorkbook.path & "\" & rng.Value & ".jpg", rng.Offset(0, 1)
    Next rng
End Sub
Code trên cho phép bạn dán tên ảnh (copy từ đâu đó) hàng loạt vào cột A hoặc D kể từ dòng 2 trở đi.

Với code trên thì sau khi chèn ảnh có thể xóa ảnh trên đĩa và khi gửi cho đối tác không phải gửi ảnh theo. Nếu bạn không xóa ảnh trên đĩa và luôn gửi ảnh kèm tập tin cho đối tác thì nên chèn link thôi để tập tin nhẹ. Trong trường hợp này sửa thành
Mã: 
InsertPicture ThisWorkbook.path & "\" & rng.Value & ".jpg", rng.Offset(0, 1), , , True
Nếu ảnh không là JPG thì sửa ".jpg" thích hợp.

Nếu ảnh ở thư mục con vd. Anh thì sửa ThisWorkbook.path & "\" thành ThisWorkbook.path & "\Anh\"

Code phục vụ 2 cột là A và D. Nếu có thêm cột thì thêm vào trong ngoặc của Union([A2:A10000], [D2:D10000])

Cuối cùng là sub tổng quát InsertPicture: Mở tập tin -> Alt + F11 -> menu Insert -> Module -> dán code dưới vào Module vừa thêm.

Để có thể dùng sub tổng quát InsertPicture trong những tập tin tương lai thì: chọn Module (click tên Module) -> menu File -> Export File -> duyệt tới thư mục cần lưu -> lưu lại với tên nào đó.BAS

Code cho Module vừa thêm
Mã: 
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False, _
                Optional LinkToFile As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell
'    Neu Target = Nothing thi Target = ActiveCell
'    Neu original = True thi nhap anh kich thuoc thuc.
'    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
'    nguoc lai thi se vua khit vung Target
'    LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
    If Target Is Nothing Then Set Target = ActiveCell
    On Error Resume Next
    Target.Parent.Shapes(Target.Address).Delete
    On Error GoTo 0
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    If fso.FileExists(PicFilename) Then
        If LinkToFile Then
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
        Else
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        End If
        If Not shp Is Nothing Then
            With shp
                If original Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                ElseIf center Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                    w = Target.Width
                    h = w * .Height / .Width
                    If h > Target.Height Then
                        h = Target.Height
                        w = h * .Width / .Height
                    End If
                    .left = Target.left + (Target.Width - w) / 2
                    .top = Target.top + (Target.Height - h) / 2
                    .Width = w
                    .Height = h
                Else
                    .Width = Target.Width
                    .Height = Target.Height
                End If
                shp.Name = Target.Address
                shp.Placement = xlMoveAndSize
            End With
        End If
    End If
  
     Set fso = Nothing
End Sub
[/
[/QUOTE]
Nhấp chuột vào đây để mở rộng...

batman1 đã viết:
Nếu cột Mã dùng công thức thì khi công thức phải tính lại do tham chiếu thay đổi thì sự kiện Change không sảy ra nên code sẽ không được thực hiện. Và kết quả là ảnh không được đổi.

Code dưới đây cho phép dán hàng loạt Mã.
-------------
Trước hết về sub tổng quát InsertPicture. Bạn có thể lưu Module cùng với InsertPicture vào "thư viện" - một thư mực nào đó, để khi cần thì chỉ (trong VBE): File -> Import File -> duyệt tới tập tin BAS đã lưu -> chọn tập tin BAS để thêm vào tập tin Excel hiện hành -> dùng Sub InsertPicture trong tập tin hiện hành.

Bạn không nên dùng Pictures vì đôi khi gặp những lỗi khó hiểu.

InsertPicture có nhiều tùy chọn: có thể nhập ảnh vào 1 ô hoặc vùng nhiều ô mà không cần merge cells, nhập ảnh với kích thước thực, nhập ảnh center trong ô/vùng hoặc vừa khít, nhập ảnh nhưng khi mang sang máy khác thì phải mang ảnh theo hoặc nhập ảnh vĩnh viễn vào sheet để khi mang sang máy khác thì không phải mang ảnh đi theo.

Tôi nhìn tập tin của bạn thì thấy bạn muốn nhập ảnh vừa khít với vùng (ảnh sẽ bị biến dạng nếu tỉ lệ cao/rộng của vùng <> cao/rộng của ảnh).
Code
Mã: 
Private Sub Worksheet_Change(ByVal Target As range)
Dim rng As range
    If Intersect(Target, Union([A2:A10000], [D2:D10000])) Is Nothing Then Exit Sub
    For Each rng In Target
        InsertPicture ThisWorkbook.path & "\" & rng.Value & ".jpg", rng.Offset(0, 1)
    Next rng
End Sub
Code trên cho phép bạn dán tên ảnh (copy từ đâu đó) hàng loạt vào cột A hoặc D kể từ dòng 2 trở đi.

Với code trên thì sau khi chèn ảnh có thể xóa ảnh trên đĩa và khi gửi cho đối tác không phải gửi ảnh theo. Nếu bạn không xóa ảnh trên đĩa và luôn gửi ảnh kèm tập tin cho đối tác thì nên chèn link thôi để tập tin nhẹ. Trong trường hợp này sửa thành
Mã: 
InsertPicture ThisWorkbook.path & "\" & rng.Value & ".jpg", rng.Offset(0, 1), , , True
Nếu ảnh không là JPG thì sửa ".jpg" thích hợp.

Nếu ảnh ở thư mục con vd. Anh thì sửa ThisWorkbook.path & "\" thành ThisWorkbook.path & "\Anh\"

Code phục vụ 2 cột là A và D. Nếu có thêm cột thì thêm vào trong ngoặc của Union([A2:A10000], [D2:D10000])

Cuối cùng là sub tổng quát InsertPicture: Mở tập tin -> Alt + F11 -> menu Insert -> Module -> dán code dưới vào Module vừa thêm.

Để có thể dùng sub tổng quát InsertPicture trong những tập tin tương lai thì: chọn Module (click tên Module) -> menu File -> Export File -> duyệt tới thư mục cần lưu -> lưu lại với tên nào đó.BAS

Code cho Module vừa thêm
Mã: 
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False, _
                Optional LinkToFile As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell
'    Neu Target = Nothing thi Target = ActiveCell
'    Neu original = True thi nhap anh kich thuoc thuc.
'    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
'    nguoc lai thi se vua khit vung Target
'    LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
    If Target Is Nothing Then Set Target = ActiveCell
    On Error Resume Next
    Target.Parent.Shapes(Target.Address).Delete
    On Error GoTo 0
  
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    If fso.FileExists(PicFilename) Then
        If LinkToFile Then
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
        Else
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        End If
        If Not shp Is Nothing Then
            With shp
                If original Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                ElseIf center Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                    w = Target.Width
                    h = w * .Height / .Width
                    If h > Target.Height Then
                        h = Target.Height
                        w = h * .Width / .Height
                    End If
                    .left = Target.left + (Target.Width - w) / 2
                    .top = Target.top + (Target.Height - h) / 2
                    .Width = w
                    .Height = h
                Else
                    .Width = Target.Width
                    .Height = Target.Height
                End If
                shp.Name = Target.Address
                shp.Placement = xlMoveAndSize
            End With
        End If
    End If
   
     Set fso = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào các bác, các bác cho em hỏi nếu muốn vùng chọn hiện ảnh là nhiều cell thì mã code viết như nào ạ. Ví dụ em muốn gộp ô nhập mã là từ N17:N25 và ô chèn ảnh là O17:O25, tương tự gộp như vậy cho các cell dưới cột N và chèn ảnh cột O. Em chưa thạo mong các bác giúp đỡ ạ!!!
 

File đính kèm

  • anh excel.jpg
    anh excel.jpg
    78.1 KB · Đọc: 11
Upvote 0
Minh Giáp đã viết:
Em chào các bác, các bác cho em hỏi nếu muốn vùng chọn hiện ảnh là nhiều cell thì mã code viết như nào ạ. Ví dụ em muốn gộp ô nhập mã là từ N17:N25 và ô chèn ảnh là O17:O25, tương tự gộp như vậy cho các cell dưới cột N và chèn ảnh cột O. Em chưa thạo mong các bác giúp đỡ ạ!!!
Nhấp chuột vào đây để mở rộng...
Bạn không đọc kỹ rồi. Tôi là người viết rất có tâm

Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Nhấp chuột vào đây để mở rộng...

Rõ ràng có: Target: vung nhap anh. Co the la nhieu cell. Và không có một chỗ nào tôi viết là Target phải MERGE CELLS, bạn tự hiểu. Không phải tức có thể, cho phép, nhưng không bắt buộc.

Nếu MÃ ở N17 cũng là tên ảnh thì Range("N17").Value, tức tên ảnh, phải nối với đường dẫn tới thư mục ảnh và định dạng của ảnh (PNG, JPG, BMP, ...) để có đường dẫn đầy đủ nhập vào PicFilename. Đọc bài có

ThisWorkbook.path & "\" & rng.Value & ".jpg"

mà không biết bắt chước thì bó tay.

Nếu vùng chèn ảnh là O17:O25 thì nhập Range("O17:O25") với tư cách là TARGET. Thế thôi.

Mà nếu không biết tường tận thì cũng phải bỏ công ra viết, dù có sai, đính kèm tập tin. Lúc đó người khác sẽ sửa. Còn ngồi rung đùi muốn người khác làm từ A đến Z thì hơi ... Thôi thì cho là hơi không phải.
 
Lần chỉnh sửa cuối:
Upvote 0
batman1 đã viết:
Bạn không đọc kỹ rồi. Tôi là người viết rất có tâm



Rõ ràng có: Target: vung nhap anh. Co the la nhieu cell. Và không có một chỗ nào tôi viết là Target phải MERGE CELLS, bạn tự hiểu. Không phải tức có thể, cho phép, nhưng không bắt buộc.

Nếu MÃ ở N17 cũng là tên ảnh thì Range("N17").Value, tức tên ảnh, phải nối với đường dẫn tới thư mục ảnh và định dạng của ảnh (PNG, JPG, BMP, ...) để có đường dẫn đầy đủ nhập vào PicFilename. Đọc bài có

ThisWorkbook.path & "\" & rng.Value & ".jpg"

mà không biết bắt chước thì bó tay.

Nếu vùng chèn ảnh là O17:O25 thì nhập Range("O17:O25") với tư cách là TARGET. Thế thôi.

Mà nếu không biết tường tận thì cũng phải bỏ công ra viết, dù có sai, đính kèm tập tin. Lúc đó người khác sẽ sửa. Còn ngồi rung đùi muốn người khác làm từ A đến Z thì hơi ... Thôi thì cho là hơi không phải.
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn bác đã chỉ rất tận tình ạ, vì rằng em mới biết đến code nên chưa hiểu để viết mà đang cần dùng mong bác thông cảm. Chúc bác thật nhiều sức khỏe ạ
 
Upvote 0
batman1 đã viết:
Mã: 
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False, _
                Optional LinkToFile As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell
'    Neu Target = Nothing thi Target = ActiveCell
'    Neu original = True thi nhap anh kich thuoc thuc.
'    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
'    nguoc lai thi se vua khit vung Target
'    LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
    If Target Is Nothing Then Set Target = ActiveCell
    On Error Resume Next
    Target.Parent.Shapes(Target.Address).Delete
    On Error GoTo 0
 
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    If fso.FileExists(PicFilename) Then
        If LinkToFile Then
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
        Else
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        End If
        If Not shp Is Nothing Then
            With shp
                If original Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                ElseIf center Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                    w = Target.Width
                    h = w * .Height / .Width
                    If h > Target.Height Then
                        h = Target.Height
                        w = h * .Width / .Height
                    End If
                    .left = Target.left + (Target.Width - w) / 2
                    .top = Target.top + (Target.Height - h) / 2
                    .Width = w
                    .Height = h
                Else
                    .Width = Target.Width
                    .Height = Target.Height
                End If
                shp.Name = Target.Address
                shp.Placement = xlMoveAndSize
            End With
        End If
    End If
  
     Set fso = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Đoạn code này của bác batman1 hay quá, tôi áp dụng vào file của mình được. Nhưng tôi không đủ giỏi để hiểu hết đoạn code này, không biết có thể sửa như thế nào để ảnh mình chèn hiển thị dưới dạng icon, nhấn vào thì ảnh mới mở lên, chứ không hiển thị trực tiếp như hiện tại được không.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

A
Trích lọc vùng dữ liệu với nhiều điều kiện
Trả lời
1
Đọc
35
Phuocam
Phuocam
LuuAnh980
Công thức lọc không trùng đơn hàng.
Trả lời
16
Đọc
243
LuuAnh980
LuuAnh980
P
Tổng hợp dữ liệu có điều kiện tại 1 sheet khác
Trả lời
1
Đọc
45
giaiphap
giaiphap
vova2209
Hàm if điều kiện mảng
Trả lời
15
Đọc
259
VetMini
V
Kiều Mạnh
Mã nguồn Add-Ins *.xll trên Delphi cho Excel
    • Thích
    • Cảm ơn
2
Trả lời
37
Đọc
4K
giaiphap
giaiphap
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom