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 ạ
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ì.
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ì.
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 ạ!