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.

 

[kuldokk]

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.

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

Sub test2()
    Dim imgFilter As String, fileName As Variant, imgH As Double, imgW As Double, posX As Double, posY As Double
    Dim cellH As Double, cellW As Double, gap As Double, ws As Worksheet, i As Integer
    
    Set ws = ActiveSheet
    
    cellH = ws.[O5]
    cellW = ws.[O6]
    
    ws.Columns.ColumnWidth = cellW
    ws.Rows.RowHeight = cellH
    
    imgH = cellH * ws.[O1]
    
    posX = ws.Cells(1, ws.[O3]).Left
    posY = ws.Cells(ws.[O2], 1).Top
    
    gap = cellH * ws.[O4]
        
    imgFilter = "Image Files(*.png),*.png," & "Image Files(*.jpg),*.jpg," & "Image Files(*.jpeg),*.jpeg," & "Image Files(*.bmp),*.bmp"
    fileName = Application.GetOpenFilename(FileFilter:=imgFilter, FilterIndex:=1, Title:="Chon anh", MultiSelect:=True)
    If Not IsArray(fileName) Then Exit Sub
    For i = LBound(fileName) To UBound(fileName)
        With ws.Pictures.Insert(fileName(i))
               With .ShapeRange
                    .LockAspectRatio = msoTrue
                    .Height = imgH
                End With
                .Left = posX
                .Top = posY + (i - 1) * (imgH + gap)
        End With
    Next i
End Sub

 

[phucymvn]

các bạn xem file sẽ hiểu rõ
Chú y: để ảnh ở folder C:\anh mau

 

[phucymvn]

xin lỗi file trước tôi gửi không lưu VBA trong đó.
Các anh xem file này và hướng dẫn em tạo vòng lặp trong đó. vì cách làm của em thủ công quá, nếu có 50 cái picture phải copy sửa tọa độ mỏi hết cả tay.
Mong các anh chỉ bảo cho
Thanks

 

[phucymvn]

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

Chào anh.
Em test thử của anh rất OK.
Nhưng khi đưa form vào thì file chạy bị lỗi. anh có thể chỉnh sửa giúp em được không?
Cám ơn

 

[viehoai]

Chào anh.
Em test thử của anh rất OK.
Nhưng khi đưa form vào thì file chạy bị lỗi. anh có thể chỉnh sửa giúp em được không?
Cám ơn

Bạn chuyển dữ liệu vùng I1:AB6 sang N1:Q6 rồi test thử xem

 

[comet_1701]

Chào anh.
Em test thử của anh rất OK.
Nhưng khi đưa form vào thì file chạy bị lỗi. anh có thể chỉnh sửa giúp em được không?
Cám ơn

Ở vùng Y chứa column witth bạn chuyển sang N1 rồi test thử nhé

 

[phucymvn]

Ở vùng Y chứa column witth bạn chuyển sang N1 rồi test thử nhé

File đã chạy.
Nhưng khi bấm nút chenanh vào thì định dạng độ rộng và độ cao bị co nhỏ hết lại vỡ hết cả format.
Các anh xem câu lệnh nào để giữ lại format là bài toán của em được giải quyết.
Cám ơn

 

[kuldokk]

File đã chạy.
Nhưng khi bấm nút chenanh vào thì định dạng độ rộng và độ cao bị co nhỏ hết lại vỡ hết cả format.
Các anh xem câu lệnh nào để giữ lại format là bài toán của em được giải quyết.
Cám ơn

Xin lỗi bác, lúc bác post #1 không kèm theo file excel nên mình trả lời ở #2 theo setup của mình nên nó bị vậy.
Gửi bác file này, chắc là đúng ý bác luôn. Tuy nhiên, có 1 lưu ý là nếu bác đã đặt tên các file theo thứ tự thì bảng cũng phải sắp xếp theo thứ tự thì mới đảm bảo được ảnh vào đúng dòng cần chèn.
Chúc thành công

Sub test3()
    Dim fileName As Variant, ws As Worksheet, i As Integer, imgCell As Range
    Const imgCol As Integer = 6
    Const imgFilter As String = "Image Files(*.png),*.png," & "Image Files(*.jpg),*.jpg," & "Image Files(*.jpeg),*.jpeg," & "Image Files(*.bmp),*.bmp"
    
    Set ws = ActiveSheet
    
    fileName = Application.GetOpenFilename(FileFilter:=imgFilter, FilterIndex:=1, Title:="Chon anh", MultiSelect:=True)
    If Not IsArray(fileName) Then Exit Sub
    For i = LBound(fileName) To UBound(fileName)
        Set imgCell = ws.Cells(11 + i - 1, imgCol)
        With ws.Pictures.Insert(fileName(i))
               With .ShapeRange
                    .LockAspectRatio = msoTrue
                    .Width = imgCell.Width
               End With
                .Left = imgCell.Left
                .Top = imgCell.Top
        End With
    Next i
End Sub

 

[phucymvn]

Xin lỗi bác, lúc bác post #1 không kèm theo file excel nên mình trả lời ở #2 theo setup của mình nên nó bị vậy.
Gửi bác file này, chắc là đúng ý bác luôn. Tuy nhiên, có 1 lưu ý là nếu bác đã đặt tên các file theo thứ tự thì bảng cũng phải sắp xếp theo thứ tự thì mới đảm bảo được ảnh vào đúng dòng cần chèn.
Chúc thành công

Cám ơn anh nhé.
Chuẩn không cần chỉnh

 

[phucymvn]

Xin lỗi bác, lúc bác post #1 không kèm theo file excel nên mình trả lời ở #2 theo setup của mình nên nó bị vậy.
Gửi bác file này, chắc là đúng ý bác luôn. Tuy nhiên, có 1 lưu ý là nếu bác đã đặt tên các file theo thứ tự thì bảng cũng phải sắp xếp theo thứ tự thì mới đảm bảo được ảnh vào đúng dòng cần chèn.
Chúc thành công

Anh Kuldokk ơi. Bài toán của em nâng cấp đòi hỏi khá cao vì khi vận dụng phát sinh ột số vấn đề.
Anh xem có thể giải quyết giúp em không?
file em gửi có 2 sheet và yêu cầu mỗi sheet em đã viết trong đó, anh xem có thuật toán nào không?
Thanks anh

 

[kuldokk]

Anh Kuldokk ơi. Bài toán của em nâng cấp đòi hỏi khá cao vì khi vận dụng phát sinh ột số vấn đề.
Anh xem có thể giải quyết giúp em không?
file em gửi có 2 sheet và yêu cầu mỗi sheet em đã viết trong đó, anh xem có thuật toán nào không?
Thanks anh

Mình thấy có 11 ô bạn cần phải chèn ảnh dựa trên điều kiện. Bạn cứ viết 11 lệnh IF điều kiện cho từng ô đó là được mà?

 

[phucymvn]

Mình thấy có 11 ô bạn cần phải chèn ảnh dựa trên điều kiện. Bạn cứ viết 11 lệnh IF điều kiện cho từng ô đó là được mà?

Thanks anh!
11 ô có điều kiện đó nhưng là 1 lệnh anh ạ. vì vậy mới khó, thuật toán này quá tầm em.
anh có thể cho em số dt em hỏi được không hoặc anh nhắn tin vào máy em 0934888988 em tên Phúc.
Thanks anh again!

 

[kuldokk]

Thanks anh!
11 ô có điều kiện đó nhưng là 1 lệnh anh ạ. vì vậy mới khó, thuật toán này quá tầm em.
anh có thể cho em số dt em hỏi được không hoặc anh nhắn tin vào máy em 0934888988 em tên Phúc.
Thanks anh again!

Check inbox
/*/*/

 

[ndu96081631]

Anh Kuldokk ơi. Bài toán của em nâng cấp đòi hỏi khá cao vì khi vận dụng phát sinh ột số vấn đề.
Anh xem có thể giải quyết giúp em không?
file em gửi có 2 sheet và yêu cầu mỗi sheet em đã viết trong đó, anh xem có thuật toán nào không?
Thanks anh

Tôi làm bài này theo kiểu khác một chút.
Đầu tiên bạn cần cho code này vào module:

Function CommPic(ByVal Pic As String, Optional ByVal Cel As Range) As String
  Dim mRng As Range, comm As Comment
  On Error Resume Next
  Application.Volatile
  If Cel Is Nothing Then Set Cel = Application.ThisCell
  Cel(1, 1).Comment.Delete
  If Not CreateObject("Scripting.FileSystemObject").FileExists(Pic) Then
    Pic = ThisWorkbook.Path & "\" & Pic
  End If
  If CreateObject("Scripting.FileSystemObject").FileExists(Pic) Then
    If Cel(1, 1).Comment Is Nothing Then Cel(1, 1).AddComment
    Cel(1, 1).Comment.Text vbLf
    Set mRng = Cel(1, 1).MergeArea
    If mRng Is Nothing Then Set mRng = Cel(1, 1)
    Set comm = mRng(1, 1).Comment
    comm.Visible = True
    With comm.Shape
      .LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Shadow.Visible = msoFalse
      .Line.Visible = msoFalse
      .AutoShapeType = msoShapeRectangle
      .Left = mRng.Left: .Top = mRng.Top
      .Width = mRng.Width: .Height = mRng.Height
      .Fill.UserPicture Pic
    End With
  End If
End Function

Tiếp theo, hãy cho hình vào cùng thư mục với file excel chứa code này
Cuối cùng là gõ hàm vào cell nào mà bạn cần chèn hình. Chẳng hạn tại sheet 5S area 1, tôi gõ công thức sau vào cell G12:

=CommPic([COLOR=#ff0000]IF($E12="","",[/COLOR][COLOR=#0000cd]$A12&G$10&".jpg"[/COLOR]))

Kéo fill hoặc copy công thức đến những cell khác
Vậy là xong!
Lưu ý:
- Muốn điều kiện thế nào thì cứ phát biểu trong hàm IF (chỗ màu đỏ)
-Nếu file hình không nằm cùng thư mục với file Excel, hãy sửa lại đường dẫn cho phù hợp (chỗ màu xanh)

 

[phucymvn]

Cám ơn Thầy.
File chạy ngon lành.

 

[nguyenanhhungutc]

chào các anh.
Em có đang gặp vấn đề chèn ảnh vào excel các anh xem sửa dùm e code này.
Thanks
-Thực trạng: Chỉ chèn được ảnh nằm trong vùng (B8:H22) - Bài toán: 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)

 

[phucymvn]

Bản của cậu gửi có code đâu?
bạn save về dạng excel macro rồi chuyển lên nhé

 

[nguyenanhhungutc]

code của nó đây ah :
Sub Rectangle1_Click()
Dim vFile, pic As Picture
vFile = Application.GetOpenFilename("All Pictures, *.bmp; *.jpg; *.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
On Error Resume Next
With ActiveCell
.Parent.Shapes(.Address).Delete
On Error GoTo 0
Set pic = .Parent.Pictures.Insert(CStr(vFile))
pic.ShapeRange.LockAspectRatio = False
pic.Left = [B8:H22].Left: pic.Top = [B8:H22].Top
pic.Width = [B8:H22].Width: pic.Height = [B8:H22].Height
pic.Placement = 1
pic.Name = .Address
End With
End If
End Sub

 

[ndu96081631]

code của nó đây ah :
Sub Rectangle1_Click()
...........................

End Sub

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