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

Liên hệ QC

ahungnv1992

Thành viên mới
Tham gia
25/6/20
Bài viết
3
Được thích
0
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 ạ
1638074217040.png
 

File đính kèm

  • data.rar
    1.1 MB · Đọc: 18

batman1

Thành viên gạo cội
Tham gia
8/9/14
Bài viết
4,985
Được thích
8,215
Khi giải thích thì phải dựa vào cấu trúc của dữ liệu thực. Ở hinh 1 theo như mô tả phải lấy tên ảnh từ khung đỏ ở phần trái để chèn vào khung đỏ ở phần phải. Trong tập tin không có phần trái, chỉ có phần phải, vậy xử lý thế nào? Tôi có thể duyệt từng vùng merge ở phần phải để lấy tên ảnh cho vùng đó thay vì đọc ở phần trái. Chỉ có điều đoán mò thì không thể chắc 100%, và nhiệm vụ của người khác không phải là đoán mò. Những cái gì bạn có thể nói ra thì phải nói ra, nói thật chi tiết và chính xác.
 

ahungnv1992

Thành viên mới
Tham gia
25/6/20
Bài viết
3
Được thích
0
Vâng em xin gửi lại File ạ!
 

File đính kèm

  • data.rar
    1.9 MB · Đọc: 13
Lần chỉnh sửa cuối:

batman1

Thành viên gạo cội
Tham gia
8/9/14
Bài viết
4,985
Được thích
8,215
Vâng em xin gửi lại File ạ!
Bạn ạ, đính kèm tập tin chỉ là 1, còn phải giải thích cho người ta hiểu.

Ở bài trước tôi thắc mắc vì từ hình đính kèm ở bài 1 suy ra là dữ liệu mean để điền vào bảng trên sheet bạn hướng dẫn lấy từ cột B cũng trên sheet, trong khi trong tập tin lại không có cột nào có mean để lấy. Còn chuyện đập ảnh và mean vào đâu tôi có thắc mắc đâu mà đính lại tập tin rồi minh họa?

Tóm lại là mean chả phải lấy từ cột B nào cả mà lấy từ tập tin CSV? Nói thế cho nó nhanh. Bằng ấy tôi cũng đoán mò được, nhưng tôi rất dị ứng với kiểu mô tả một đường, cần phải làm một nẻo. Vì thế mà tôi góp ý.

Tôi làm như tôi hiểu, và cho cấu trúc trong tập tin ở bài 1.

1. Alt + F11 để vào VBE -> menu Insert -> Module -> chèn code sau và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 là code tổng quát để chèn ảnh vào sheet. Trong bất cứ tập tin nào sau này mà cần chèn ảnh thì dùng nó. Đọc ghi chú để biết cách dùng.

2. Cũng như trên thêm Module2 và chè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 để chèn mean và ảnh. Chỉ chạy code này. Trong code tôi chèn ảnh vĩnh viễn, tức sau khi chèn có thể xóa ảnh trên đĩa, gửi tập tin cho đối tác không cần đính kèm ảnh đi theo. Nếu muốn chỉ chèn LINK thì ở dòng InsertPicture ... nhập tham số cuối cùng là True. Lúc này không được phép xóa ảnh, và ảnh luôn phải đi kèm với tập tin Excel. Code viết cho trường hợp khi ảnh nằm trong thư mục "Anh". Hãy đổi tên thư mục từ "File ảnh" thành "Anh" - ngắn gọn và không có dấu tiếng Việt. Ở đây không có nhu cầu dùng tiếng Việt, bầy vẽ ra làm gì.
 

ahungnv1992

Thành viên mới
Tham gia
25/6/20
Bài viết
3
Được thích
0
Vâng em xin gửi lại File ạ!

Bạn ạ, đính kèm tập tin chỉ là 1, còn phải giải thích cho người ta hiểu.

Ở bài trước tôi thắc mắc vì từ hình đính kèm ở bài 1 suy ra là dữ liệu mean để điền vào bảng trên sheet bạn hướng dẫn lấy từ cột B cũng trên sheet, trong khi trong tập tin lại không có cột nào có mean để lấy. Còn chuyện đập ảnh và mean vào đâu tôi có thắc mắc đâu mà đính lại tập tin rồi minh họa?

Tóm lại là mean chả phải lấy từ cột B nào cả mà lấy từ tập tin CSV? Nói thế cho nó nhanh. Bằng ấy tôi cũng đoán mò được, nhưng tôi rất dị ứng với kiểu mô tả một đường, cần phải làm một nẻo. Vì thế mà tôi góp ý.

Tôi làm như tôi hiểu, và cho cấu trúc trong tập tin ở bài 1.

1. Alt + F11 để vào VBE -> menu Insert -> Module -> chèn code sau và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 là code tổng quát để chèn ảnh vào sheet. Trong bất cứ tập tin nào sau này mà cần chèn ảnh thì dùng nó. Đọc ghi chú để biết cách dùng.

2. Cũng như trên thêm Module2 và chè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 để chèn mean và ảnh. Chỉ chạy code này. Trong code tôi chèn ảnh vĩnh viễn, tức sau khi chèn có thể xóa ảnh trên đĩa, gửi tập tin cho đối tác không cần đính kèm ảnh đi theo. Nếu muốn chỉ chèn LINK thì ở dòng InsertPicture ... nhập tham số cuối cùng là True. Lúc này không được phép xóa ảnh, và ảnh luôn phải đi kèm với tập tin Excel. Code viết cho trường hợp khi ảnh nằm trong thư mục "Anh". Hãy đổi tên thư mục từ "File ảnh" thành "Anh" - ngắn gọn và không có dấu tiếng Việt. Ở đây không có nhu cầu dùng tiếng Việt, bầy vẽ ra làm gì.

Bạn ạ, đính kèm tập tin chỉ là 1, còn phải giải thích cho người ta hiểu.

Ở bài trước tôi thắc mắc vì từ hình đính kèm ở bài 1 suy ra là dữ liệu mean để điền vào bảng trên sheet bạn hướng dẫn lấy từ cột B cũng trên sheet, trong khi trong tập tin lại không có cột nào có mean để lấy. Còn chuyện đập ảnh và mean vào đâu tôi có thắc mắc đâu mà đính lại tập tin rồi minh họa?

Tóm lại là mean chả phải lấy từ cột B nào cả mà lấy từ tập tin CSV? Nói thế cho nó nhanh. Bằng ấy tôi cũng đoán mò được, nhưng tôi rất dị ứng với kiểu mô tả một đường, cần phải làm một nẻo. Vì thế mà tôi góp ý.

Tôi làm như tôi hiểu, và cho cấu trúc trong tập tin ở bài 1.

1. Alt + F11 để vào VBE -> menu Insert -> Module -> chèn code sau và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 là code tổng quát để chèn ảnh vào sheet. Trong bất cứ tập tin nào sau này mà cần chèn ảnh thì dùng nó. Đọc ghi chú để biết cách dùng.

2. Cũng như trên thêm Module2 và chè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 để chèn mean và ảnh. Chỉ chạy code này. Trong code tôi chèn ảnh vĩnh viễn, tức sau khi chèn có thể xóa ảnh trên đĩa, gửi tập tin cho đối tác không cần đính kèm ảnh đi theo. Nếu muốn chỉ chèn LINK thì ở dòng InsertPicture ... nhập tham số cuối cùng là True. Lúc này không được phép xóa ảnh, và ảnh luôn phải đi kèm với tập tin Excel. Code viết cho trường hợp khi ảnh nằm trong thư mục "Anh". Hãy đổi tên thư mục từ "File ảnh" thành "Anh" - ngắn gọn và không có dấu tiếng Việt. Ở đây không có nhu cầu dùng tiếng Việt, bầy vẽ ra làm gì.
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 ạ!
 
Web KT
Top Bottom