Chèn hình ảnh theo điều kiện của một ô có trước (1 người xem)

[malia]

Em đang cần một đoạn code dùng để chèn hình ảnh theo một ô có điều kiện.Ở trên diễn đàn thì em cũng thấy có nhiều mục về việc này, nhưng em không thể tự sửa được theo ý của em. Mong các bác giúp đỡ ^^Chi tiết ở trong file excel ạ! Em cảm ơn nhiều nhiều

 

[ndu96081631]

Em đang cần một đoạn code dùng để chèn hình ảnh theo một ô có điều kiện.Ở trên diễn đàn thì em cũng thấy có nhiều mục về việc này, nhưng em không thể tự sửa được theo ý của em. Mong các bác giúp đỡ ^^Chi tiết ở trong file excel ạ! Em cảm ơn nhiều nhiều

Cách bố trí dữ liệu của bạn như vậy không hiệu quả đâu... Chẳng lẽ với 1000 hình bạn cũng chèn hết vào bảng tính sao?
Nên lưu các hình vào 1 thư mực riêng, đặt tên phân biết từng hình và khi nào cần thì chèn vào bảng tính

 

[malia]

không bác ạ, cái này chỉ có khoảng vài hình cơ bản thôi ạ! cảm ơn về ý kiến của bác!

 

[ndu96081631]

không bác ạ, cái này chỉ có khoảng vài hình cơ bản thôi ạ! cảm ơn về ý kiến của bác!

Vậy thì tạm làm theo code này thử:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim DataRng As Range, fRng As Range, Pic As Picture, pItem As Picture
  On Error Resume Next
  If Target.Column = 1 Then
    If Target.Row >= 5 Then
      If Target.Count = 1 Then
        ActiveSheet.Shapes(Target.Address).Delete
        On Error GoTo ExitSub
        Set DataRng = Sheet1.Range("A2:B1000")
        Set fRng = DataRng.Find(Target.Value, , , xlWhole)
        If Not fRng Is Nothing Then
          fRng.Offset(, 1).Copy
          Target.Parent.Pictures.Paste
          For Each pItem In Sheet2.Pictures
            If pItem.Name Like "Picture*" Then
              Set Pic = pItem: Exit For
            End If
          Next
          With ActiveSheet.Shapes(Pic.Name)
            .LockAspectRatio = False
            .Top = Target.Top: .Left = Target.Offset(, 1).Left
            .Height = Target.Height: .Width = Target.Offset(, 1).Width
            .Name = Target.Address
          End With
ExitSub:
          Application.CutCopyMode = 0
        End If
      End If
    End If
  End If
End Sub

Chưa biết có cách nào hay hơn
Xem file

 

[ngocphapx3d]

Cảm ơn thầy Ndu nhiều, em đang cần cái này!

 

[ngocphapx3d]

Vậy thì tạm làm theo code này thử:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim DataRng As Range, fRng As Range, Pic As Picture, pItem As Picture
  On Error Resume Next
  If Target.Column = 1 Then
    If Target.Row >= 5 Then
      If Target.Count = 1 Then
        ActiveSheet.Shapes(Target.Address).Delete
        On Error GoTo ExitSub
        Set DataRng = Sheet1.Range("A2:B1000")
        Set fRng = DataRng.Find(Target.Value, , , xlWhole)
        If Not fRng Is Nothing Then
          fRng.Offset(, 1).Copy
          Target.Parent.Pictures.Paste
          For Each pItem In Sheet2.Pictures
            If pItem.Name Like "Picture*" Then
              Set Pic = pItem: Exit For
            End If
          Next
          With ActiveSheet.Shapes(Pic.Name)
            .LockAspectRatio = False
            .Top = Target.Top: .Left = Target.Offset(, 1).Left
            .Height = Target.Height: .Width = Target.Offset(, 1).Width
            .Name = Target.Address
          End With
ExitSub:
          Application.CutCopyMode = 0
        End If
      End If
    End If
  End If
End Sub

Chưa biết có cách nào hay hơn
Xem file

Chào thầy,
Đoạn code thầy cho rất có ích với em trong việc chèn hình ảnh, em áp dụng mà chỉ chèn được hình ảnh ở cột B còn chèn ở cột khác em chưa làm được, nhờ thầy chỉ giúp em với. Cảm ơn thầy nhiều!

 

[ngocphapx3d]

Em vừa tìm ra rồi thầy!