Tự tạo sheet mới theo sheet mẫu và chèn ảnh theo thư mục.

Liên hệ QC
dazkangel

dazkangel

<New Horizons>
Tham gia
28/2/17
Bài viết
2,880
Được thích
4,039
Giới tính
Nam
Nhờ Anh(Chị) giúp em viết 1 đoạn mã là tự động copy từ sheet cũ và đổi tên sheet thành tên thư mục và chèn ảnh vào các ô theo tên file là 1 đến 5 có đuôi là jpg.
Tự thu nhỏ đều ảnh bằng chiều cao của khung và canh giữa giúp em theo file sau:
em cảm ơn nhiều.
 

File đính kèm

  • taosheetchenanh.zip
    602.5 KB · Đọc: 35
Sắp xếp theo thời gian sắp xếp theo bầu chọn
dazkangel đã viết:
Nhờ Anh(Chị) giúp em viết 1 đoạn mã là tự động copy từ sheet cũ và đổi tên sheet thành tên thư mục và chèn ảnh vào các ô theo tên file là 1 đến 5 có đuôi là jpg.
Tự thu nhỏ đều ảnh bằng chiều cao của khung và canh giữa giúp em theo file sau:
em cảm ơn nhiều.
Nhấp chuột vào đây để mở rộng...
Anh ơi sao sau khi đưa vào CONATINER nó lại biến thành loại khác. Khiếp ... Như Tôn Ngộ Không ấy :p:p:p
 

File đính kèm

  • test1.xlsm
    37.2 KB · Đọc: 16
Upvote 0
dazkangel đã viết:
Nhờ Anh(Chị) giúp em viết 1 đoạn mã là tự động copy từ sheet cũ và đổi tên sheet thành tên thư mục và chèn ảnh vào các ô theo tên file là 1 đến 5 có đuôi là jpg.
Tự thu nhỏ đều ảnh bằng chiều cao của khung và canh giữa giúp em theo file sau:
em cảm ơn nhiều.
Nhấp chuột vào đây để mở rộng...
Bài toán chèn hình đúng rất dễ nhưng bạn lại vộ tình tự làm khó mình
1> Thứ nhất: Thiết kế form trên sheet không ra hình thù gì cả (không có quy luật)
2> Thứ hai: Không có mối liên hệ nào giữa tên hình và nơi chứa hình. Ít ra thì tên hình cũng được đặt theo quy luật gì đó giống với dữ liệu trên sheet
---------------------------------
♫ђöล♥ßล†♥†µ♫ đã viết:
Anh ơi sao sau khi đưa vào CONATINER nó lại biến thành loại khác. Khiếp ... Như Tôn Ngộ Không ấy :p:p:p
Nhấp chuột vào đây để mở rộng...
Chỉ có mỗi việc chèn hình mà đâu ra đống code khủng khiếp vậy bạn?
 
Upvote 0
ndu96081631 đã viết:
Chỉ có mỗi việc chèn hình mà đâu ra đống code khủng khiếp vậy bạn?
Nhấp chuột vào đây để mở rộng...
Cái này hôm trước em có đọc ở một trang tiếng tây tiếng tầu thấy họ làm em lưu lại. Hôm nay bê nguyên si vào.
HieuCD đã viết:
Code không thích máy tính mình nên không chịu chạy o_O

View attachment 199179
Nhấp chuột vào đây để mở rộng...
Tại nó thấy Anh mập quá nên nó không tăng chiều ngang thêm ấy mà :p:p:p
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Bài toán chèn hình đúng rất dễ nhưng bạn lại vộ tình tự làm khó mình
1> Thứ nhất: Thiết kế form trên sheet không ra hình thù gì cả (không có quy luật)
2> Thứ hai: Không có mối liên hệ nào giữa tên hình và nơi chứa hình. Ít ra thì tên hình cũng được đặt theo quy luật gì đó giống với dữ liệu trên sheet
---------------------------------

Chỉ có mỗi việc chèn hình mà đâu ra đống code khủng khiếp vậy bạn?
Nhấp chuột vào đây để mở rộng...
Có nhiều thứ mong mà không được anh à, em chỉ dựa theo ảnh theo thứ tự tên 1,2,3,4,5 thôi anh :D
 
Upvote 0
Cho code vào 1 module. Code cần chạy là load_images

Mã: 
Option Explicit

Sub load_images()
Dim k As Long, dirname As String, rangenames
    rangenames = Array("A10:F24", "H10:M24", "D27:J41", "P10:U24", "W10:AB24")
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .AllowMultiSelect = True
'        If .Show <> 0 Then dirname = .SelectedItems(1)
'    End With
    dirname = ThisWorkbook.path & "\cacloaihoa"
'    If dirname <> "" Then
        With ThisWorkbook
            .Worksheets("Mau").Copy After:=.Worksheets(.Worksheets.Count)
        End With
        ActiveSheet.Name = Mid(dirname, InStrRev(dirname, "\") + 1)
        For k = 1 To 5
            InsertPicture dirname & "\" & k & ".jpg", range(rangenames(k - 1)), , True
        Next k
'    End If
End Sub

Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell - khong can Merge
'    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
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
        Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        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
 
Upvote 0
batman1 đã viết:
Cho code vào 1 module. Code cần chạy là load_images

Mã: 
Option Explicit

Sub load_images()
Dim k As Long, dirname As String, rangenames
    rangenames = Array("A10:F24", "H10:M24", "D27:J41", "P10:U24", "W10:AB24")
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .AllowMultiSelect = True
'        If .Show <> 0 Then dirname = .SelectedItems(1)
'    End With
    dirname = ThisWorkbook.path & "\cacloaihoa"
'    If dirname <> "" Then
        With ThisWorkbook
            .Worksheets("Mau").Copy After:=.Worksheets(.Worksheets.Count)
        End With
        ActiveSheet.Name = Mid(dirname, InStrRev(dirname, "\") + 1)
        For k = 1 To 5
            InsertPicture dirname & "\" & k & ".jpg", range(rangenames(k - 1)), , True
        Next k
'    End If
End Sub

Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell - khong can Merge
'    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
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
        Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        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...
E,m chạy thì nó báo lỗi như thế này.
12.PNG
 
Upvote 0
huonglien1901 đã viết:
E,m chạy thì nó báo lỗi như thế này.
View attachment 199205
Nhấp chuột vào đây để mở rộng...
Đây chỉ là ví dụ thôi. Nếu tập tin đã có sheet cacloaihoa thì dĩ nhiên không thể copy sheet Mau rồi lại đặt tên là cacloaihoa được. Vì người hỏi không tự trình bầy nên tôi không thể viết cụ thể được. Vd. không thể mỗi lần chạy code là copy sheet Mau rồi đặt cho nó 1 cái tên bất di bất dịch cacloaihoa, rồi nhập 5 ảnh vẫn là tên 1, 2, 3, 4, 5. Như thế vô nghĩa quá. Vân vân và mây mây.

Người hỏi phải tự cung cấp thông tin: mỗi lần chạy code thì lấy tên sheet mới ở đâu, lấy tên các ảnh cho sheet hiện hành ở đâu.

Không thể chỉ cho 1 ví dụ rồi mong người khác làm hộ cả thiết kế dữ liệu lẫn viết code được.

Cái khung đã có, code làm các việc đã có, bây giờ tự thêm mắm, thêm muối thôi.
---------------
Nếu bạn để ý kỹ thì thấy có đoạn code được chuyển thành chú thích. Nếu là mỗi lần chạy code sẽ chọn thư mục có ảnh và đồng thời lấy nó làm tên sheet hiện hành thay cho cái tên bất di bất dịch cacloaihoa thì "mở" đoạn code đó để dùng và xóa dòng dirname = ThisWorkbook.path & "\cacloaihoa" đi thôi. Không phải vô cớ mà tôi vẫn để đoạn code chọn thư mục nhưng biến nó thành chú thích. Ai chịu khó suy nghĩ chút thì biết dùng, biết biến hóa code. Không suy nghĩ thì nói 1 chỉ biết 1. Thế thôi.

Tất nhiên code hoàn chỉnh còn phải kiểm tra vd. sheet với tên như thế đã tồn tại chưa.
 
Lần chỉnh sửa cuối:
Upvote 0
♫ђöล♥ßล†♥†µ♫ đã viết:
Anh ơi sao sau khi đưa vào CONATINER nó lại biến thành loại khác. Khiếp ... Như Tôn Ngộ Không ấy :p:p:p
Nhấp chuột vào đây để mở rộng...
Không hiểu sao chạy được cảm ơn rất nhiều.
batman1 đã viết:
Đây chỉ là ví dụ thôi. Nếu tập tin đã có sheet cacloaihoa thì dĩ nhiên không thể copy sheet Mau rồi lại đặt tên là cacloaihoa được. Vì người hỏi không tự trình bầy nên tôi không thể viết cụ thể được. Vd. không thể mỗi lần chạy code là copy sheet Mau rồi đặt cho nó 1 cái tên bất di bất dịch cacloaihoa, rồi nhập 5 ảnh vẫn là tên 1, 2, 3, 4, 5. Như thế vô nghĩa quá. Vân vân và mây mây.

Người hỏi phải tự cung cấp thông tin: mỗi lần chạy code thì lấy tên sheet mới ở đâu, lấy tên các ảnh cho sheet hiện hành ở đâu.

Không thể chỉ cho 1 ví dụ rồi mong người khác làm hộ cả thiết kế dữ liệu lẫn viết code được.

Cái khung đã có, code làm các việc đã có, bây giờ tự thêm mắm, thêm muối thôi.
---------------
Nếu bạn để ý kỹ thì thấy có đoạn code được chuyển thành chú thích. Nếu là mỗi lần chạy code sẽ chọn thư mục có ảnh và đồng thời lấy nó làm tên sheet hiện hành thay cho cái tên bất di bất dịch cacloaihoa thì "mở" đoạn code đó để dùng và xóa dòng dirname = ThisWorkbook.path & "\cacloaihoa" đi thôi. Không phải vô cớ mà tôi vẫn để đoạn code chọn thư mục nhưng biến nó thành chú thích. Ai chịu khó suy nghĩ chút thì biết dùng, biết biến hóa code. Không suy nghĩ thì nói 1 chỉ biết 1. Thế thôi.

Tất nhiên code hoàn chỉnh còn phải kiểm tra vd. sheet với tên như thế đã tồn tại chưa.
Nhấp chuột vào đây để mở rộng...
Dạ chào anh, hình thì nó là tên của file chụp từ máy ảnh.
Ảnh chụp không phải lúc nào cũng đầy đủ với thứ tự nên em phải đổi tên cho tiện thao tác xác định tên vào ô nào.
Sheet cacloaihoa là sheet đã tạo để em làm ví dụ thôi, em không biết gì về VBA nên đành nghĩ sao thì nói vậy nên có nhiều chỗ vẫn chưa được đủ ý.
Trong file em có nêu là các thư mục ảnh sẽ nằm cùng vị trí với file excel luôn ạ.
 
Upvote 0

File đính kèm

  • test1.xlsm
    37.5 KB · Đọc: 12
Upvote 0
Lần chỉnh sửa cuối:
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

hung2412
  • Question
Có Code VBA nào để tự động điều chỉnh tỷ lệ hiển thị màn hình theo thông số Recommended (Theo từng Laptop, PC)?
Trả lời
0
Đọc
1
hung2412
hung2412
Linh Nguyễn 9991
  • Question
Tạo nút VBA trong Excel để in file Word với tính năng Mail Merge
Trả lời
6
Đọc
324
Linh Nguyễn 9991
Linh Nguyễn 9991
H
Giúp em đặt thêm công thức cho phép năm
    • Chấp nhận
Trả lời
4
Đọc
144
Hoàng Tuấn 868
H
8
  • Question
Xin giúp: Nhóm (group data) các dòng trong bảng tính
Trả lời
10
Đọc
372
DeTong
D
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
6
Đọc
227
VetMini
V
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