Nhờ hướng dẫn code VBA chèn ảnh tự động (1 người xem)

[o2mobile]

Em nhờ các anh chỉ giúp làm sao để tạo được file như mẫu bằng VBA.
Em gửi file excel đính kèm.

Em có các ảnh được đánh số thứ tự từ 1 đến n nằm trong một thư mục như ô "J3"
Bây giờ em muốn viết code để

1. lấy ảnh tự động từ trong thư mục ở ô J3 sắp xếp theo thứ tự từ 1 đến n vừa khít các ô .

2, mỗi hàng có 2 ảnh. số lượng ảnh lấy ra theo ô I3. Chiều cao, rộng ảnh được lấy theo ô G3 và H3.

3. Dưới mỗi ảnh có chỗ ghi chú thích sẵn là chữ "Ảnh" còn phần sau tên là gì em điền tay sau.

4. Nếu đến ảnh thứ i mà không có thì kiểm tra tiếp 5 ảnh liên tiếp mà không có thì dừng (ý ảnh số i là ảnh cuối, n= i). còn nếu < 5 thì chạy tiếp.
Ví dụ ảnh 4.jpg là không có => kiểm tra ảnh 5.jpg ... 8.jpg
- Nếu từ 5.jpg đến 8.jpg mà không có thì end sub.
- Nếu từ 5-8.jpg giả sử là 6.jpg có thì vẫn tiếp tục.

5. Dưới các ô không có ảnh . ví dụ ảnh 4 thì vẫn điền chữ bên dưới là "Ảnh số 4"

Do em mới làm quen VBA nên em nhờ các anh chỉ dẫn code càng chi tiết càng tốt ạ.
Em cám ơn các anh rất nhiều.

 

[ndu96081631]

Em nhờ các anh chỉ giúp làm sao để tạo được file như mẫu bằng VBA.
Em gửi file excel đính kèm.

Em có các ảnh được đánh số thứ tự từ 1 đến n nằm trong một thư mục như ô "J3"
Bây giờ em muốn viết code để

1. lấy ảnh tự động từ trong thư mục ở ô J3 sắp xếp theo thứ tự từ 1 đến n vừa khít các ô .

2, mỗi hàng có 2 ảnh. số lượng ảnh lấy ra theo ô I3. Chiều cao, rộng ảnh được lấy theo ô G3 và H3.

3. Dưới mỗi ảnh có chỗ ghi chú thích sẵn là chữ "Ảnh" còn phần sau tên là gì em điền tay sau.

4. Nếu đến ảnh thứ i mà không có thì kiểm tra tiếp 5 ảnh liên tiếp mà không có thì dừng (ý ảnh số i là ảnh cuối, n= i). còn nếu < 5 thì chạy tiếp.
Ví dụ ảnh 4.jpg là không có => kiểm tra ảnh 5.jpg ... 8.jpg
- Nếu từ 5.jpg đến 8.jpg mà không có thì end sub.
- Nếu từ 5-8.jpg giả sử là 6.jpg có thì vẫn tiếp tục.

5. Dưới các ô không có ảnh . ví dụ ảnh 4 thì vẫn điền chữ bên dưới là "Ảnh số 4"

Do em mới làm quen VBA nên em nhờ các anh chỉ dẫn code càng chi tiết càng tốt ạ.
Em cám ơn các anh rất nhiều.

Vào đây tham khảo thử xem:
http://www.giaiphapexcel.com/diendan/threads/chèn-hình-vào-cell-bằng-hàm-tự-tạo.51408/

 

[o2mobile]

Em đã viết code nhưng khi chạy vẫn bị lỗi này mà chưa sửa được ạ:
"KHi ảnh số 11 không có, em cho kiểm tra từ ảnh 12 đến ảnh 15. điền chữ vào ô ảnh số 11, tuy nhiên nó điền đến tận ảnh số 15. trong khi số ảnh cho phép đến 12 (số ảnh cần điền).

Em xin gửi code và file kèm nhờ các anh hướng dẫn ạ.
Em cám ơn.
===================================================
Sub Insert_Picture()
Dim PicWidth As Integer
Dim PicHeight As Integer
Dim TextHeight As Integer
Dim NumberOfRow As Integer
Dim NumberOfPic As Integer
Dim i, j As Integer
Dim SttAnh As Integer
Dim Gap As Integer
Dim PathOfPic As String
Dim picname As String
Dim dem As Integer
Dim demloi As Integer
Dim gitrakt, giatrikt1 As Integer

PicHeight = Worksheets(1).Range("I2").Value
PicWidth = [J2]
Gap = [K2]
NumberOfPic = Worksheets(1).Range("M2").Value
TextHeight = [L2]
NumberOfRow = WorksheetFunction.Ceiling(NumberOfPic / 2, 1)
PathOfPic = [N2]
SttAnh = 1

'============================================================
' Thay doi rong cot
Columns("A").ColumnWidth = PicWidth
Columns("B").ColumnWidth = Gap
Columns("C").ColumnWidth = PicWidth
'============================================================
For i = 1 To NumberOfRow
' thay doi do cao dong
Rows(2 * i - 1).RowHeight = PicHeight
Rows(2 * i).RowHeight = TextHeight

' Vong lap cua hang
For j = 1 To 3
If SttAnh <= NumberOfPic Then

If j Mod 2 <> 0 Then ' j la hang so le
'============================================================
' Chen anh
MsgBox "So thu thu anh: " & SttAnh

picname = "C:\Users\QUOC KHANH\Desktop\pic\" & SttAnh & ".jpg" 'Link to the picture

If FileExists(picname) = True Then ' Xem file anh co ton tai hay khong?
ActiveSheet.Pictures.Insert(picname).Select

With Selection ' Dinh dang cho anh
.Left = Cells(2 * i - 1, j).Left
.Top = Cells(2 * i - 1, j).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = Cells(2 * i - 1, j).Height
.ShapeRange.Width = Cells(2 * i - 1, j).Width
.ShapeRange.Rotation = 0#
End With

'Gan chu viet
Worksheets(1).Cells(2 * i, j).Value = "Hinh so: " & SttAnh

Else
MsgBox "Anh khong ton tai"
GoTo ErrNoPhoto

End If
'=========================================================================
Check:
SttAnh = SttAnh + 1
'=========================================================================
End If
End If
Next j
Next i
'============================================================
ErrNoPhoto:
MsgBox "Da den loi"
giatrikt = SttAnh + 4 'Cho kiem tra 5 anh ke tiep
For dem = SttAnh To giatrikt

picname = "C:\Users\QUOC KHANH\Desktop\pic\" & dem & ".jpg"

If FileExists(picname) = False Then
demloi = demloi + 1
Else
demloi = 0

End If

Next dem

If demloi >= 5 Then 'Kiem tra khong co 5 anh ke tiep thoat sub
Exit Sub
Else
MsgBox "Dem loi: " & demloi
Worksheets(1).Cells(2 * i, j).Value = "Hinh so: " & SttAnh
GoTo Check 'Neu demloi < 5 thi chay lai chuong trinh
End If

End Sub
'============================================================
Function FileExists(filename) As Boolean
On Error GoTo ErrorHandler
FileExists = (Dir(filename) <> "")
Exit Function
ErrorHandler:
FileExists = False
End Function
'============================================================