Sử dụng VBA ghép nhiều ảnh và dữ liệu File excel đóng vào File tổng hợp

ahungnv1992 · 28/11/21

Xin chào các anh!
Hiện em đang làm việc tổng hợp 1 ngày gần 100 báo cáo excel gồm :
Hình ảnh + dữ liệu File data( File Excel).
Em muốn các anh giúp đỡ sử dung VBA để ghép báo cáo tự động hình ảnh và Data excel trong cùng 1 Folder vào file tổng hợp ạ.
Mục tiêu :
+ ghép các hình ảnh có tên vào ô điền tên tương ứng trong File tổng hợp
+ lấy dữ liệu từ cột B (mean) vào các ô dữ liệu tương ứng trong file tông hợp.
En xin gửi file đính kèm ạ

Rất mong sự giúp đỡ của các anh ! Em xin chân thành cảm ơn ạ

batman1 · 28/11/21

Khi giải thích thì phải dựa vào cấu trúc của dữ liệu thực. Ở hinh 1 theo như mô tả phải lấy tên ảnh từ khung đỏ ở phần trái để chèn vào khung đỏ ở phần phải. Trong tập tin không có phần trái, chỉ có phần phải, vậy xử lý thế nào? Tôi có thể duyệt từng vùng merge ở phần phải để lấy tên ảnh cho vùng đó thay vì đọc ở phần trái. Chỉ có điều đoán mò thì không thể chắc 100%, và nhiệm vụ của người khác không phải là đoán mò. Những cái gì bạn có thể nói ra thì phải nói ra, nói thật chi tiết và chính xác.

ahungnv1992 · 29/11/21

Vâng em xin gửi lại File ạ!

batman1 · 29/11/21

ahungnv1992 đã viết:
Vâng em xin gửi lại File ạ!

Bạn ạ, đính kèm tập tin chỉ là 1, còn phải giải thích cho người ta hiểu.

Ở bài trước tôi thắc mắc vì từ hình đính kèm ở bài 1 suy ra là dữ liệu mean để điền vào bảng trên sheet bạn hướng dẫn lấy từ cột B cũng trên sheet, trong khi trong tập tin lại không có cột nào có mean để lấy. Còn chuyện đập ảnh và mean vào đâu tôi có thắc mắc đâu mà đính lại tập tin rồi minh họa?

Tóm lại là mean chả phải lấy từ cột B nào cả mà lấy từ tập tin CSV? Nói thế cho nó nhanh. Bằng ấy tôi cũng đoán mò được, nhưng tôi rất dị ứng với kiểu mô tả một đường, cần phải làm một nẻo. Vì thế mà tôi góp ý.

Tôi làm như tôi hiểu, và cho cấu trúc trong tập tin ở bài 1.

1. Alt + F11 để vào VBE -> menu Insert -> Module -> chèn code sau vào Module1

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

Đây là code tổng quát để chèn ảnh vào sheet. Trong bất cứ tập tin nào sau này mà cần chèn ảnh thì dùng nó. Đọc ghi chú để biết cách dùng.

2. Cũng như trên thêm Module2 và chèn code

Mã:

Sub chen_dulieu()
Const anh_dong_dau = 10 ' dong 10
Const anh_cot_dau = 3   ' cot C
Dim r As Long, c As Long, curr_row As Long, text As String, lines, mean(1 To 5, 1 To 4), fso As Object, ts As Object, rng As range, currRange As range
    Set fso = CreateObject("Scripting.FileSystemObject")
    text = fso.OpenTextFile(ThisWorkbook.Path & "\data.csv", , , 0).ReadAll     ' doc tat ca noi dung CSV
    Set fso = Nothing
    lines = Split(text, vbCrLf) ' chia thanh tung dong
    For c = 1 To 4
        For r = 1 To 5
            curr_row = (c - 1) * 5 + r
            If c > UBound(lines) Then Exit For  ' de phong CSV thieu du lieu - thieu dong
            text = lines(curr_row)  ' noi dung dong hien hanh
            If Len(text) Then mean(r, c) = Split(text, ",")(1)  ' cho vao manh mean
        Next r
        If c > UBound(lines) Then Exit For
    Next c
    With ThisWorkbook.Worksheets("Impedance")
        .range("E3").Resize(UBound(mean, 1), UBound(mean, 2)).Value = mean  ' do mean xuong sheet
    
        For r = 1 To 4  ' duyet tung dong
            For c = 1 To 5  ' trong moi dong duyet tung cot
                Set currRange = .Cells(anh_dong_dau + (r - 1) * 4, anh_cot_dau + (c - 1) * 3)   ' cell o goc trai ben tren cua vung hien hanh
                InsertPicture ThisWorkbook.Path & "\Anh\" & currRange.Value & ".png", currRange.MergeArea, False, False, False  ' chen anh
            Next c
        Next r
    End With
End Sub

Code trên để chèn mean và ảnh. Chỉ chạy code này. Trong code tôi chèn ảnh vĩnh viễn, tức sau khi chèn có thể xóa ảnh trên đĩa, gửi tập tin cho đối tác không cần đính kèm ảnh đi theo. Nếu muốn chỉ chèn LINK thì ở dòng InsertPicture ... nhập tham số cuối cùng là True. Lúc này không được phép xóa ảnh, và ảnh luôn phải đi kèm với tập tin Excel. Code viết cho trường hợp khi ảnh nằm trong thư mục "Anh". Hãy đổi tên thư mục từ "File ảnh" thành "Anh" - ngắn gọn và không có dấu tiếng Việt. Ở đây không có nhu cầu dùng tiếng Việt, bầy vẽ ra làm gì.

ahungnv1992 · 29/11/21

ahungnv1992 đã viết:
Vâng em xin gửi lại File ạ!

batman1 đã viết:
Bạn ạ, đính kèm tập tin chỉ là 1, còn phải giải thích cho người ta hiểu.

Ở bài trước tôi thắc mắc vì từ hình đính kèm ở bài 1 suy ra là dữ liệu mean để điền vào bảng trên sheet bạn hướng dẫn lấy từ cột B cũng trên sheet, trong khi trong tập tin lại không có cột nào có mean để lấy. Còn chuyện đập ảnh và mean vào đâu tôi có thắc mắc đâu mà đính lại tập tin rồi minh họa?

Tóm lại là mean chả phải lấy từ cột B nào cả mà lấy từ tập tin CSV? Nói thế cho nó nhanh. Bằng ấy tôi cũng đoán mò được, nhưng tôi rất dị ứng với kiểu mô tả một đường, cần phải làm một nẻo. Vì thế mà tôi góp ý.

Tôi làm như tôi hiểu, và cho cấu trúc trong tập tin ở bài 1.

1. Alt + F11 để vào VBE -> menu Insert -> Module -> chèn code sau vào Module1

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

Đây là code tổng quát để chèn ảnh vào sheet. Trong bất cứ tập tin nào sau này mà cần chèn ảnh thì dùng nó. Đọc ghi chú để biết cách dùng.

2. Cũng như trên thêm Module2 và chèn code

Mã:

Sub chen_dulieu() Const anh_dong_dau = 10 ' dong 10 Const anh_cot_dau = 3 ' cot C Dim r As Long, c As Long, curr_row As Long, text As String, lines, mean(1 To 5, 1 To 4), fso As Object, ts As Object, rng As range, currRange As range Set fso = CreateObject("Scripting.FileSystemObject") text = fso.OpenTextFile(ThisWorkbook.Path & "\data.csv", , , 0).ReadAll ' doc tat ca noi dung CSV Set fso = Nothing lines = Split(text, vbCrLf) ' chia thanh tung dong For c = 1 To 4 For r = 1 To 5 curr_row = (c - 1) * 5 + r If c > UBound(lines) Then Exit For ' de phong CSV thieu du lieu - thieu dong text = lines(curr_row) ' noi dung dong hien hanh If Len(text) Then mean(r, c) = Split(text, ",")(1) ' cho vao manh mean Next r If c > UBound(lines) Then Exit For Next c With ThisWorkbook.Worksheets("Impedance") .range("E3").Resize(UBound(mean, 1), UBound(mean, 2)).Value = mean ' do mean xuong sheet For r = 1 To 4 ' duyet tung dong For c = 1 To 5 ' trong moi dong duyet tung cot Set currRange = .Cells(anh_dong_dau + (r - 1) * 4, anh_cot_dau + (c - 1) * 3) ' cell o goc trai ben tren cua vung hien hanh InsertPicture ThisWorkbook.Path & "\Anh\" & currRange.Value & ".png", currRange.MergeArea, False, False, False ' chen anh Next c Next r End With End Sub

Code trên để chèn mean và ảnh. Chỉ chạy code này. Trong code tôi chèn ảnh vĩnh viễn, tức sau khi chèn có thể xóa ảnh trên đĩa, gửi tập tin cho đối tác không cần đính kèm ảnh đi theo. Nếu muốn chỉ chèn LINK thì ở dòng InsertPicture ... nhập tham số cuối cùng là True. Lúc này không được phép xóa ảnh, và ảnh luôn phải đi kèm với tập tin Excel. Code viết cho trường hợp khi ảnh nằm trong thư mục "Anh". Hãy đổi tên thư mục từ "File ảnh" thành "Anh" - ngắn gọn và không có dấu tiếng Việt. Ở đây không có nhu cầu dùng tiếng Việt, bầy vẽ ra làm gì.

Em cảm ơn anh nhiều ạ.! Code có kèm chú thích rất dễ hiểu anh ạ.Em xin rút kinh nghiệm khi không trình bày rõ ràng vấn đề. Chúc anh thật nhiều sức khỏe và thành công ạ!

Sử dụng VBA ghép nhiều ảnh và dữ liệu File excel đóng vào File tổng hợp

ahungnv1992

Thành viên mới

File đính kèm

batman1

Thành viên gạo cội

ahungnv1992

Thành viên mới

File đính kèm

batman1

Thành viên gạo cội

ahungnv1992

Thành viên mới

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

Facebook

Group

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