Tạo vòng lặp chèn hình bằng VBA (1 người xem)

[phucymvn]

Chào các anh!
Hiện tại công việc em đang gặp phải như sau:
1. Hàng ngày đi chụp ảnh các vấn đề không theo tiêu chuẩn
2. điền vào báo cáo.
em thấy mỗi lần làm như thế mất rất nhiều thời gian khiínnsert picture vào vì ảnh chèn vào rất to và phải chỉnh về kích cỡ nhỏ.
Em đã cải tiến bằng cách đổi tên file ảnh là: 1, 2, 3..... n. sau đó viết macros theo kiểu nông dân như sau:
Sub chenanh()
'
' chenanh Macro
' chen anh vao cell theo size
'
' Keyboard Shortcut: Ctrl+q
'
Range("F12").Select
ActiveSheet.Pictures.Insert("C:\Users\phdang\Desktop\anh mau\1.jpg").Select
Selection.ShapeRange.Height = 86.4
Range("F13").Select
ActiveSheet.Pictures.Insert("C:\Users\phdang\Desktop\anh mau\2.jpg").Select
Selection.ShapeRange.Height = 86.4
Range("F14").Select
ActiveSheet.Pictures.Insert("C:\Users\phdang\Desktop\anh mau\3.jpg").Select
Selection.ShapeRange.Height = 86.4
End Sub

Mong các anh làm giúp em 2 việc:
tạo vòng lặp để cell f12 mỗi lần sẽ là fi+1 và ảnh sẽ là tọa độ j+1. ( Trong đó j, i mình điền tọa độ vào thì tốt)
Cám ơn.

 

[nguyenanhhungutc]

Thanks a ndu96081631 !

 

[langtuchungtinh360]

Sửa code thành vầy thử xem:

Sub Rectangle1_Click()
  Dim vFiles, pic As Picture, picItem, n As Long
  Application.ScreenUpdating = False
  vFiles = Application.GetOpenFilename("All Pictures, *.bmp; *.jpg; *.jpeg;*.png;*.gif", , , , True)
  If TypeName(vFiles) = "Variant()" Then
    DelPics
    For Each picItem In vFiles
      On Error Resume Next
      With Range("B8:H22").Offset(n * 15)
        .Parent.Shapes(.Address).Delete
        On Error GoTo 0
        Set pic = .Parent.Pictures.Insert(CStr(picItem))
        pic.ShapeRange.LockAspectRatio = False
        pic.Left = .Left: pic.Top = .Top
        pic.Width = .Width: pic.Height = .Height
        pic.Placement = 1
        pic.Name = .Address
        n = n + 1
      End With
    Next
  End If
  Application.ScreenUpdating = True
End Sub
Private Sub DelPics()
  Dim pic As Object
  For Each pic In Sheet1.Pictures
    If pic.Name Like "$*:$*" Then pic.Delete
  Next
End Sub

Lưu ý: Khi bấm nút chạy code, cửa sổ chọn file hình hiện ra, bạn có thể chọn nhiều file hình cùng lúc bằng cách click chuột kết hợp với bấm phím Shift hoặc Ctrl
Thử xem

thầy du cho em hỏi có cách nào chèn ảnh tự động luôn ko thầy. ví dụ như em đang cần chèn ảnh vào theo điều kiện cho trước. ví dụ như code thầy cho thì khi em nhập vào ô A8 số 1 thì hình sẽ tự động lấy tấm ảnh tên 1 từ thư mục chèn vào ô B8:H22 (ngang với ô điều kiện) và kế tiếp sẽ dò điều kiện ở ô A23 để chèn tấm ảnh tên 2 (giá trị ô A23 là 2) vào ô B22:H37, chèn tiếp tiếp như đoạn code trên thực hiện ấy thầy, nhưng mà chèn theo điều kiện ở cột A và chèn tự động luôn. em xin lỗi nếu em nói hơi dài dòng và khó hiểu.
cho em hỏi thêm sao em chép đoạn code trong file của thầy qua file khác thì bị lỗi không chạy được và báo lỗi ở dòng For Each pic In Sheet1.Pictures.

 

[ndu96081631]

thầy du cho em hỏi có cách nào chèn ảnh tự động luôn ko thầy. ví dụ như em đang cần chèn ảnh vào theo điều kiện cho trước. ví dụ như code thầy cho thì khi em nhập vào ô A8 số 1 thì hình sẽ tự động lấy tấm ảnh tên 1 từ thư mục chèn vào ô B8:H22 (ngang với ô điều kiện) và kế tiếp sẽ dò điều kiện ở ô A23 để chèn tấm ảnh tên 2 (giá trị ô A23 là 2) vào ô B22:H37, chèn tiếp tiếp như đoạn code trên thực hiện ấy thầy, nhưng mà chèn theo điều kiện ở cột A và chèn tự động luôn. em xin lỗi nếu em nói hơi dài dòng và khó hiểu.

Xem chỗ này trước đi rồi tính tiếp:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Chèn-hình-vào-cell-bằng-hàm-tự-tạo
Nếu "tự tính" vẫn không ra, cho file + hình lên đây

cho em hỏi thêm sao em chép đoạn code trong file của thầy qua file khác thì bị lỗi không chạy được và báo lỗi ở dòng For Each pic In Sheet1.Pictures.

Chắc là file của bạn hổng có sheet nào là Sheet1 cả (đoán thôi, ai mà biết chứ)

 

[nguyenanhhungutc]

Hi anh ndu96081631
anh có thể s code trong file đính kèm:
- Chèn được ảnh nằm trong vùng ('B8-2mm':'H22-2mm') ( Ảnh được chèn cách đường bao 1:2 mm )
- Tạo vòng lặp chèn ảnh khi bấm vào nút "chenanh" sẽ chèn được các ảnh trong Folder theo thư tự khu vực chèn (từ 1, 2,3…i)
Thanks !

 

[nguyenthai24]

thử cái này nhé, hướng dẫn trong file, test trên office 2010, 2013 rồi


[/code]

Chào Kuldokk, có thể inbox cho mình địa chỉ mail được không, mình có vấn đề cần hỏi, gửi mail sẽ nói rõ ràng hơn.

Cám ơn và mong hồi âm.