Tự động chèn ảnh vừa ô trong excel (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

ARCH_ANGEL

Thành viên chính thức
Tham gia
16/2/13
Bài viết
55
Được thích
2
Kính chào các anh chị.
Sau khi tham khảo một số bài viết, em vẫn chưa tìm ra được bài nào phù hợp với nhu cầu của mình. Rất mong các anh chị giúp em với cái đề bài của em.
Em có 2 cột: 1 cột tên mã hàng, cột còn lại là mô tả (ảnh sản phẩm). Em muốn sau khi gõ xong hết mã hàng, chạy lệnh sẽ tự động chèn hình ảnh sản phẩm sang cột bên cạnh tương ứng với mã hàng đó, hình ảnh được lưu trong máy tính với tên từng ảnh tương tự mã sản phẩm. Mã nào không có sản phẩm sẽ để trống ô
Em thấy có 1 số code chèn ảnh tuy vừa với ô có sẵn nhưng lại bị mất dòng kẻ của ô, một số copy gửi sang cho người khác thì lại không thấy ảnh.
Em xin cám ơn mọi người, dưới là file mẫu e đính kèm mong mọi người giúp đỡ.
---------------------------------------------------------------------------------------------------------------------------------------------------
Em xin cám ơn anh befaint và thầy ndu96081631 đã giúp em hoàn thiện được đề bài của em.
Dưới đây là 2 phương án cho đề bài này để mọi người tham khảo:
Mã: 
[COLOR=#0000BB][FONT=monospace][I]Sub insertIMG[/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I]()
[/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]Dim path [/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I]As [/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]String
Dim img [/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I]As [/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]Object
Dim cll [/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I]As [/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]Range
path [/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I]= [/I][/FONT][/COLOR][COLOR=#DD0000][FONT=monospace][I]"D:\Google drive\Caesar\San Pham\Picture\"
For Each cll In Range("[/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]B3[/I][/FONT][/COLOR][COLOR=#DD0000][FONT=monospace][I]", Range("[/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]B65000[/I][/FONT][/COLOR][COLOR=#DD0000][FONT=monospace][I]").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & "[/I][/FONT][/COLOR][COLOR=#007700][FONT=monospace][I].[/I][/FONT][/COLOR][COLOR=#0000BB][FONT=monospace][I]jpg[/I][/FONT][/COLOR][COLOR=#DD0000][FONT=monospace][I]")
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then
                img.Width = a - 3
                img.Top = .Top + 0.5 * (b - img.Height)
                img.Left = .Left + 3
            End If
            If b * x / y <= a Then
                img.Height = b - 3
                img.Top = .Top + 3
                img.Left = .Left + 0.5 * (a - img.Width)
            End If
        End With
    End If
Next
End Sub  [/I][/FONT][/COLOR]
[INFO1]Thanks to befaint[/INFO1]

Mã: 
[COLOR=#000000]Private Sub InsertPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
[/COLOR]                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1)
  Dim pic As Picture, fso As Object, bChk As Boolean
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = ActiveCell
  bChk = fso.FileExists(PicPath)
  If bChk = False Then
    PicPath = ActiveWorkbook.path & "\" & PicPath
    bChk = fso.FileExists(PicPath)
  End If
  If bChk Then
    On Error Resume Next
    PicCel.Parent.Pictures(PicCel.Address(0, 0)).Delete
    On Error GoTo 0
    Set pic = PicCel.Parent.Pictures.Insert(PicPath)
    With pic
      .ShapeRange.LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Left = PicCel.Left: .Top = PicCel.Top
      .Width = PicCel.Width: .Height = PicCel.Height
      .ShapeRange.ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ShapeRange.ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Name = PicCel.Address(0, 0)
    End With
  End If
  Set fso = Nothing 
[COLOR=#000000]End Sub
[/COLOR][COLOR=#000000]Sub Main()[/COLOR]  Dim rng As Range, cel As Range
  Dim sFolder As String, PicPath As String
  Set rng = Sheet1.Range("B3", Sheet1.Range("B10000").End(xlUp))
  [B][COLOR=#ff0000]With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show Then sFolder = .SelectedItems(1)
  End With[/COLOR][/B]
  If Len(sFolder) Then
    If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
    For Each cel In rng
      PicPath = sFolder & cel.Value & ".jpg"
      InsertPic PicPath, cel.Offset(, 1), [B][COLOR=#0000cd]0.8[/COLOR][/B], [B][COLOR=#0000cd]0.8[/COLOR][/B]
    Next
    MsgBox "Done!"
  End If [COLOR=#000000]End Sub[/COLOR]
[INFO1]Thanks to ndu96081631[/INFO1]
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Folder "Picture" chứa ảnh (file *.jpg) và file excel nằm trong cùng 1 Folder.

PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
path = ThisWorkbook.path & "\Picture\"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.Top = .Top
            img.Left = .Left
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width
            b = .Height
            If a * y / x <= b Then img.Width = a
            If b * x / y <= a Then img.Height = b
        End With
    End If
Next
End Sub
 
Upvote 0
befaint đã viết:
Folder "Picture" chứa ảnh (file *.jpg) và file excel nằm trong cùng 1 Folder.

PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
path = ThisWorkbook.path & "\Picture\"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.Top = .Top
            img.Left = .Left
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width
            b = .Height
            If a * y / x <= b Then img.Width = a
            If b * x / y <= a Then img.Height = b
        End With
    End If
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh rất nhiều nhưng mục picture kia có cần chỉnh lại đường dẫn chi tiết k (như D:\aaa\Picture)
Và em làm kiểu gì cũng k thấy có hiện tượng gì xảy ra, k hiểu sao nữa.
File ảnh và file tài liệu e thường để 2 mục riêng rẽ khác nhau, vậy có cách nào tách 2 file ra vẫn add được không a?
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn sửa lại dòng:
path = ThisWorkbook.path & "\Picture"
Thành:
path = "D:\aaa\Picture\"
 
Upvote 0
befaint đã viết:
Bạn sửa lại dòng:
path = ThisWorkbook.path & "\Picture"
Thành:
path = "D:\aaa\Picture\"
Nhấp chuột vào đây để mở rộng...
Cám ơn anh, code đã chạy được rồi, nhưng vẫn bị lỗi như nhiều người khác, đó là đưa ảnh vào nhưng không cân vào giữa ô, và che mất dòng kẻ của ô, thành ra khi in ra bị mất hết dòng kẻ của bảng. Mong anh giúp nốt cho vấn đề này
 
Upvote 0
ARCH_ANGEL đã viết:
Cám ơn anh, code đã chạy được rồi, nhưng vẫn bị lỗi như nhiều người khác, đó là đưa ảnh vào nhưng không cân vào giữa ô, và che mất dòng kẻ của ô, thành ra khi in ra bị mất hết dòng kẻ của bảng. Mong anh giúp nốt cho vấn đề này
Nhấp chuột vào đây để mở rộng...
Bài #1 không thấy bạn nói chèn ảnh vào giữa ô (chính giữa theo 2 phương?), mà tiêu đề yêu cầu vừa ô...
Bạn thử như vầy xem:
PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
path = "D:\aaa\Picture"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.Top = .Top + 3
            img.Left = .Left + 3
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then img.Width = a - 3
            If b * x / y <= a Then img.Height = b - 3
        End With
    End If
Next
End Sub
 
Upvote 0
befaint đã viết:
Bài #1 không thấy bạn nói chèn ảnh vào giữa ô (chính giữa theo 2 phương?), mà tiêu đề yêu cầu vừa ô...
Bạn thử như vầy xem:
PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
path = "D:\aaa\Picture"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.Top = .Top + 3
            img.Left = .Left + 3
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then img.Width = a - 3
            If b * x / y <= a Then img.Height = b - 3
        End With
    End If
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Chào anh. Xin lỗi đã không nói rõ, a giúp cho ảnh cách đều 4 phương (căn chính giữa ô). Ở đây ảnh chèn vào đã hết bị mất dòng kẻ rồi, nhưng ảnh vẫn bị lêch sang trái, chưa vào giữa ô.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn gửi file của bạn lên xem bị mất dòng kẻ như nào?
Còn canh giữa ô: Tôi đang để theo bên trái sẽ dễ nhìn hơn (vì ảnh có nhiều kích thước dài x rộng khác nhau).

Chỉnh giữa giữa ô:
PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
'path = ThisWorkbook.path & "\Picture\"
path = "D:\aaa\Picture"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then
                img.Width = a - 3
                img.Top = .Top + 0.5 * (b - img.Height)
                img.Left = .Left + 3
            End If
            If b * x / y <= a Then
                img.Height = b - 3
                img.Top = .Top + 3
                img.Left = .Left + 0.5 * (a - img.Width)
            End If
        End With
    End If
Next
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Bạn gửi file của bạn lên xem bị mất dòng kẻ như nào?
Còn canh giữa ô: Tôi đang để theo bên trái sẽ dễ nhìn hơn (vì ảnh có nhiều kích thước dài x rộng khác nhau).

Chỉnh giữa giữa ô:
PHP: 
Sub chen_anh()
Dim path As String
Dim img As Object
Dim cll As Range
'path = ThisWorkbook.path & "\Picture\"
path = "D:\aaa\Picture"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then
                img.Width = a - 3
                img.Top = .Top + 0.5 * (b - img.Height)
                img.Left = .Left + 3
            End If
            If b * x / y <= a Then
                img.Height = b - 3
                img.Top = .Top + 3
                img.Left = .Left + 0.5 * (a - img.Width)
            End If
        End With
    End If
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Đây là file + ảnh. Hiện tại thì mọi thứ gần như ok hết rồi, mỗi tội ảnh vẫn chưa vào chính giữa hẳn. Mong a giúp sửa nốt chút xíu nữa là ok. Cám ơn anh rất nhiều
 
Lần chỉnh sửa cuối:
Upvote 0
ARCH_ANGEL đã viết:
Đây là file + ảnh. Hiện tại thì mọi thứ gần như ok hết rồi, mỗi tội ảnh vẫn chưa vào chính giữa hẳn. Mong a giúp sửa nốt chút xíu nữa là ok. Cám ơn anh rất nhiều
Nhấp chuột vào đây để mở rộng...
Bó tay...
Bạn đọc lại bài #4 và bài #8.

Bạn xóa hết code trong file của bạn rồi chép cái đoạn dưới này vào:
PHP: 
Sub insertIMG()
Dim path As String
Dim img As Object
Dim cll As Range
path = "D:\Google drive\Caesar\San Pham\Picture\"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then
                img.Width = a - 3
                img.Top = .Top + 0.5 * (b - img.Height)
                img.Left = .Left + 3
            End If
            If b * x / y <= a Then
                img.Height = b - 3
                img.Top = .Top + 3
                img.Left = .Left + 0.5 * (a - img.Width)
            End If
        End With
    End If
Next
End Sub
 
Upvote 0
befaint đã viết:
Bó tay...
Bạn đọc lại bài #4 và bài #8.

Bạn xóa hết code trong file của bạn rồi chép cái đoạn dưới này vào:
PHP: 
Sub insertIMG()
Dim path As String
Dim img As Object
Dim cll As Range
path = "D:\Google drive\Caesar\San Pham\Picture\"
For Each cll In Range("B3", Range("B65000").End(xlUp))
    If cll <> 0 Then
        With cll.Offset(0, 1)
            Set img = Nothing
            On Error Resume Next
            Set img = Sheet1.Pictures.Insert(path & cll.Value & ".jpg")
            img.LockAspectRatio = msoTrue
            x = img.Width
            y = img.Height
            a = .Width - 3
            b = .Height - 3
            If a * y / x <= b Then
                img.Width = a - 3
                img.Top = .Top + 0.5 * (b - img.Height)
                img.Left = .Left + 3
            End If
            If b * x / y <= a Then
                img.Height = b - 3
                img.Top = .Top + 3
                img.Left = .Left + 0.5 * (a - img.Width)
            End If
        End With
    End If
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Chắc tại lúc up lên em chưa lưu vào, chứ thực ra em có add code mới nhất ở bài 8 của a và đã chạy thử rồi, và có bảo ở bài 9 rằng là mọi thứ đều ok chỉ có điều ảnh đã vào giữa nhưng vẫn chưa vào hẳn chính giữa thôi (ảnh vẫn hơi lệch về bên trái)
 
Lần chỉnh sửa cuối:
Upvote 0
Code bạn befaint dùng có đoạn:
Mã: 
LockAspectRatio = msoTrue
Chắc ăn 100% luôn sẽ không bao giờ canh được kích thước ảnh như ý. Nó sẽ lệch tùm lum và đặc biệt là có máy bị lệch có máy lại không
 
Upvote 0
ndu96081631 đã viết:
Code bạn befaint dùng có đoạn:
Mã: 
LockAspectRatio = msoTrue
Chắc ăn 100% luôn sẽ không bao giờ canh được kích thước ảnh như ý. Nó sẽ lệch tùm lum và đặc biệt là có máy bị lệch có máy lại không
Nhấp chuột vào đây để mở rộng...
Dạ chào thầy. Thầy có thể chỉ giúp em và anh @befaint làm thế nào để có thể căn được ảnh vào chính giữa ạ.
Nhân tiện em mới phát hiện thêm 1 lỗi nữa, em chạy code cứ loay hoay mãi bảo quái lạ sao code vẫn thế tự tạo file mới thì vẫn tự động add ảnh được, sao làm với cái nhiều sheet thì lại không thấy tự add ảnh, hóa ra mở sang sheet bên cạnh thì ảnh tùm lum bên đó !%^&*()....
 
Lần chỉnh sửa cuối:
Upvote 0
ARCH_ANGEL đã viết:
Dạ chào thầy. Thầy có thể chỉ giúp em và anh @befaint làm thế nào để có thể căn được ảnh vào chính giữa ạ.
Nhân tiện em mới phát hiện thêm 1 lỗi nữa, em chạy code cứ loay hoay mãi bảo quái lạ sao code vẫn thế tự tạo file mới thì vẫn tự động add ảnh được, sao làm với cái nhiều sheet thì lại không thấy tự add ảnh, hóa ra mở sang sheet bên cạnh thì ảnh tùm lum bên đó !%^&*()....
Nhấp chuột vào đây để mở rộng...
Tôi viết code như vầy:
Mã: 
Private Sub InsertPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1)
  Dim pic As Picture, fso As Object, bChk As Boolean
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = ActiveCell
  bChk = fso.FileExists(PicPath)
  If bChk = False Then
    PicPath = ActiveWorkbook.path & "\" & PicPath
    bChk = fso.FileExists(PicPath)
  End If
  If bChk Then
    On Error Resume Next
    PicCel.Parent.Pictures(PicCel.Address(0, 0)).Delete
    On Error GoTo 0
    Set pic = PicCel.Parent.Pictures.Insert(PicPath)
    With pic
      .ShapeRange.LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Left = PicCel.Left: .Top = PicCel.Top
      .Width = PicCel.Width: .Height = PicCel.Height
      .ShapeRange.ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ShapeRange.ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Name = PicCel.Address(0, 0)
    End With
  End If
  Set fso = Nothing
End Sub
Mã: 
Sub Main()
  Dim rng As Range, cel As Range
  Dim sFolder As String, PicPath As String
  Set rng = Sheet1.Range("B3", Sheet1.Range("B10000").End(xlUp))
  [B][COLOR=#ff0000]With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show Then sFolder = .SelectedItems(1)
  End With[/COLOR][/B]
  If Len(sFolder) Then
    If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
    For Each cel In rng
      PicPath = sFolder & cel.Value & ".jpg"
      InsertPic PicPath, cel.Offset(, 1), [B][COLOR=#0000cd]0.8[/COLOR][/B], [B][COLOR=#0000cd]0.8[/COLOR][/B]
    Next
    MsgBox "Done!"
  End If
End Sub
1> Cách dùng:
- Cho toàn bộ code trên vào 1 Module
- Bấm Alt + F8, chon Main để chạy. Một cửa sổ chọn thư mục sẽ hiện ra, bạn chọn thư mục chứa hình rồi bấm nút OK
- Chờ xem kết quả
2> Lưu ý:
- Đoạn code màu đỏ nếu bạn không thích kiểu mở folder để chọn thì bạn có thể ghi đường dẫn trực tiếp vào, chẳng hạn sFolder = "D:\Google drive\Caesar\San Pham\Picture"
- 2 con số 0.8 màu xanh trong code là tỉ lệ thu nhỏ hình theo chiều ngang và dọc (để hình không đè lên đường lưới). Bạn có thể chỉnh 2 con số này tùy ý (nếu bỏ qua 2 đối số này thì mặc định nó sẽ =1, tức hình vừa khít vói cell)
- Đoạn code trên cùng có mục đích tổng quát hóa quá hình chèn hình. Cú pháp cần nhớ:
Mã: 
InsertPic "Đường dẫn đến file hình", cell đặt hình, tỉ lệ thu nhỏ hình theo chiều ngang, tỉ lệ thu nhỏ hình theo chiều dọc
- Đoạn code trên cùng thật ra bạn không cần quan tâm, chỉ quan tâm Sub Main và khai báo đúng là được
-----------------------
Trong file đính kèm dưới đây tôi còn tặng thêm bạn 1 code chèn hình dùng Comment, bạn gõ hàm trực tiếp trên cell sẽ có ngay hình mà không cần phải bấm nút chạy code
 

File đính kèm

Upvote 0
ndu96081631 đã viết:
Tôi viết code như vầy:
Mã: 
Private Sub InsertPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1)
  Dim pic As Picture, fso As Object, bChk As Boolean
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = ActiveCell
  bChk = fso.FileExists(PicPath)
  If bChk = False Then
    PicPath = ActiveWorkbook.path & "\" & PicPath
    bChk = fso.FileExists(PicPath)
  End If
  If bChk Then
    On Error Resume Next
    PicCel.Parent.Pictures(PicCel.Address(0, 0)).Delete
    On Error GoTo 0
    Set pic = PicCel.Parent.Pictures.Insert(PicPath)
    With pic
      .ShapeRange.LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Left = PicCel.Left: .Top = PicCel.Top
      .Width = PicCel.Width: .Height = PicCel.Height
      .ShapeRange.ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ShapeRange.ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Name = PicCel.Address(0, 0)
    End With
  End If
  Set fso = Nothing
End Sub
Mã: 
Sub Main()
  Dim rng As Range, cel As Range
  Dim sFolder As String, PicPath As String
  Set rng = Sheet1.Range("B3", Sheet1.Range("B10000").End(xlUp))
  [B][COLOR=#ff0000]With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show Then sFolder = .SelectedItems(1)
  End With[/COLOR][/B]
  If Len(sFolder) Then
    If Right$(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
    For Each cel In rng
      PicPath = sFolder & cel.Value & ".jpg"
      InsertPic PicPath, cel.Offset(, 1), [B][COLOR=#0000cd]0.8[/COLOR][/B], [B][COLOR=#0000cd]0.8[/COLOR][/B]
    Next
    MsgBox "Done!"
  End If
End Sub
1> Cách dùng:
- Cho toàn bộ code trên vào 1 Module
- Bấm Alt + F8, chon Main để chạy. Một cửa sổ chọn thư mục sẽ hiện ra, bạn chọn thư mục chứa hình rồi bấm nút OK
- Chờ xem kết quả
2> Lưu ý:
- Đoạn code màu đỏ nếu bạn không thích kiểu mở folder để chọn thì bạn có thể ghi đường dẫn trực tiếp vào, chẳng hạn sFolder = "D:\Google drive\Caesar\San Pham\Picture"
- 2 con số 0.8 màu xanh trong code là tỉ lệ thu nhỏ hình theo chiều ngang và dọc (để hình không đè lên đường lưới). Bạn có thể chỉnh 2 con số này tùy ý (nếu bỏ qua 2 đối số này thì mặc định nó sẽ =1, tức hình vừa khít vói cell)
- Đoạn code trên cùng có mục đích tổng quát hóa quá hình chèn hình. Cú pháp cần nhớ:
Mã: 
InsertPic "Đường dẫn đến file hình", cell đặt hình, tỉ lệ thu nhỏ hình theo chiều ngang, tỉ lệ thu nhỏ hình theo chiều dọc
- Đoạn code trên cùng thật ra bạn không cần quan tâm, chỉ quan tâm Sub Main và khai báo đúng là được
-----------------------
Trong file đính kèm dưới đây tôi còn tặng thêm bạn 1 code chèn hình dùng Comment, bạn gõ hàm trực tiếp trên cell sẽ có ngay hình mà không cần phải bấm nút chạy code
Nhấp chuột vào đây để mở rộng...
Cám ơn thầy rất nhiều, cả 2 code đều chạy rất tốt. Tuy có điều không hiểu sao sheet em đặt tên khác không phải tên là Sheet1 thì k thể nào chạy được code dù đã thay lại tên trong code: "Set rng = Bao Gia (2).Range("B3", Bao Gia (2).Range("B10000").End(xlUp))". Em đổi tên lại Sheet1 thì lại ok, tìm lại trong các dòng code không thấy chỗ nào quy định phải là sheet1 ngoài dòng này nữa. Mong thầy chỉ giúp nốt.
 
Lần chỉnh sửa cuối:
Upvote 0
ARCH_ANGEL đã viết:
Cám ơn thầy rất nhiều, cả 2 code đều chạy rất tốt. Tuy có điều không hiểu sao sheet em đặt tên khác không phải tên là Sheet1 thì k thể nào chạy được code dù đã thay lại tên trong code: "Set rng = Bao Gia (2).Range("B3", Bao Gia (2).Range("B10000").End(xlUp))". Em đổi tên lại Sheet1 thì lại ok, tìm lại trong các dòng code không thấy chỗ nào quy định phải là sheet1 ngoài dòng này nữa. Mong thầy chỉ giúp nốt.
Nhấp chuột vào đây để mở rộng...

Ghi vậy là sai!
Cái Sheet1 tôi ghi trong code là tên sheet trong VBA. Còn bạn muốn dùng tên sheet ngoài bảng tính thì phải ghi thế này:
Mã: 
[COLOR=#000000]Set rng = [/COLOR][COLOR=#ff0000]Sheets("Bao Gia (2)")[/COLOR][COLOR=#000000].Range("B3", [/COLOR][COLOR=#000000][COLOR=#ff0000]Sheets("Bao Gia (2)")[/COLOR].Range("B10000").End(xlUp))
Tóm lại nếu dùng tên sheet ngoài bảng tính để tham chiếu thì phải ghi theo cú pháp: Sheets("Tên sheet")
[/COLOR]
 
Upvote 0
ndu96081631 đã viết:
Ghi vậy là sai!
Cái Sheet1 tôi ghi trong code là tên sheet trong VBA. Còn bạn muốn dùng tên sheet ngoài bảng tính thì phải ghi thế này:
Mã: 
[COLOR=#000000]Set rng = [/COLOR][COLOR=#ff0000]Sheets("Bao Gia (2)")[/COLOR][COLOR=#000000].Range("B3", [/COLOR][COLOR=#000000][COLOR=#ff0000]Sheets("Bao Gia (2)")[/COLOR].Range("B10000").End(xlUp))[/COLOR]

Tóm lại nếu dùng tên sheet ngoài bảng tính để tham chiếu thì phải ghi theo cú pháp: Sheets("Tên sheet")
Nhấp chuột vào đây để mở rộng...
Cám ơn thầy về những hướng dẫn rất chi tiết, dễ hiểu với những người biết ít về VBA như em. Mọi thứ đều tốt hết rồ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

A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn (2 người xem)
Trả lời
1
Đọc
32
ptm0412
ptm0412
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
15
Đọc
262
ptm0412
ptm0412
dangvandang
Addin mở rộng cho xây dựng
    • Thích
2
Trả lời
34
Đọc
3K
vlba
V
M
  • Question Question
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
4
Đọc
118
mtbackup
M
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
3
Đọc
157
hoangtuaotrang_hp_vn
H
A
ExTools : Hơn 60 tính năng bổ sung cho Excel (2 người xem)
    • Thích
Trả lời
3
Đọc
9K
mangat060083
M
anhtuan1066
  • Question Question
Đọc số thành chữ có phần thập phân
Trả lời
12
Đọc
8K
caocat
C
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
114
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
155
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
97
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD
    • Cười
Trả lời
0
Đọc
116
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (2 người xem)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
90
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
4
Đọc
89
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng (1 người xem)
Trả lời
3
Đọc
110
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++
    • Thích
Trả lời
0
Đọc
128
nguyendang95
N
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom