Chèn hình ảnh vào theo điều kiện, ứng với dữ liệu ở sheet data (4 người xem)

[ngoctruong142]

Chào các anh chị!

Nhờ các anh chị viết dùm code
Mình muốn chèn hình ảnh trong vào ô có điều kiện (ví dụ trong khu vưc từ I6 đến O15) nếu ô trong khu vực đó bằng 1 thì chèn hình ảnh (dữ liệu trong sheet data) vào ô đó, còn tại ô đó = 0 thì không chèn).

Mong các anh chị giúp cho. Cám ơn

file đính kèm ví dụ: View attachment chen anh.xlsx

 

[phucbugis]

Chào các anh chị!

Nhờ các anh chị viết dùm code
Mình muốn chèn hình ảnh trong vào ô có điều kiện (ví dụ trong khu vưc từ I6 đến O15) nếu ô trong khu vực đó bằng 1 thì chèn hình ảnh (dữ liệu trong sheet data) vào ô đó, còn tại ô đó = 0 thì không chèn).

Mong các anh chị giúp cho. Cám ơn

file đính kèm ví dụ: View attachment 115814

Bạn mở file, xem có đúng với yêu cầu đó ko.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
    If Not Intersect(Target, Range("I7:O15")) Is Nothing Then
    On Error GoTo Thoat 'khi xoa' vung`
        If Target.Value = 1 Then
            Set cl = Range(Target.Address)
            
            Sheets("data").Shapes("hinh1").Copy
            
            ActiveSheet.Paste
            Selection.Width = cl.Width
        End If
    End If
    
Thoat:
    Exit Sub
End Sub

Link MediaFire: chen anh (1)

 

[ngoctruong142]

Cám ơn anh nhiều, đúng ý mình mong muốn

 

[ngoctruong142]

Bạn mở file, xem có đúng với yêu cầu đó ko.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
    If Not Intersect(Target, Range("I7:O15")) Is Nothing Then
    On Error GoTo Thoat 'khi xoa' vung`
        If Target.Value = 1 Then
            Set cl = Range(Target.Address)
            
            Sheets("data").Shapes("hinh1").Copy
            
            ActiveSheet.Paste
            Selection.Width = cl.Width
        End If
    End If
    
Thoat:
    Exit Sub
End Sub

Anh có thể thêm đoạn code để khi chèn hình vô thì nó nằm ở giữa ô được không? Cám ơn

 

[phucbugis]

Anh có thể thêm đoạn code để khi chèn hình vô thì nó nằm ở giữa ô được không? Cám ơn

Bạn sửa: Selection.Width = cl.Width thành

With Selection
.Width = cl.Width
.Top = cl.Top + cl.Height / 2
End With

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
    If Not Intersect(Target, Range("I7:O15")) Is Nothing Then
    On Error GoTo Thoat 'khi xoa' vung`
        If Target.Value = 1 Then
            Set cl = Range(Target.Address)
            
            Sheets("data").Shapes("hinh1").Copy
            
            ActiveSheet.Paste
            [COLOR=#ff0000][B]With Selection
                .Width = cl.Width
                .Top = cl.Top + cl.Height / 2
            End With[/B][/COLOR]
        End If
    End If
    
Thoat:
    Exit Sub
End Sub

 

[ndu96081631]

Bạn mở file, xem có đúng với yêu cầu đó ko.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
    If Not Intersect(Target, Range("I7:O15")) Is Nothing Then
    On Error GoTo Thoat 'khi xoa' vung`
        If Target.Value = 1 Then
            Set cl = Range(Target.Address)
            
            Sheets("data").Shapes("hinh1").Copy
            
            ActiveSheet.Paste
            Selection.Width = cl.Width
        End If
    End If
    
Thoat:
    Exit Sub
End Sub

Giờ bạn thí nghiệm thế này nhé:
- Chọn Cell I7
- Bấm F2 rồi Enter
- Thao tác như trên chừng 10 lần
- Kiểm tra lại xem hiện tại trên sheet đang có bao nhiều hình
Tóm lại: Nguyên tắc là phải xóa hình cũ trước khi chèn hình mới, nếu không sẽ có 1 ngày file nặng như "cục đá" mà không hiểu tại sao

 

[phucbugis]

Giờ bạn thí nghiệm thế này nhé:
- Chọn Cell I7
- Bấm F2 rồi Enter
- Thao tác như trên chừng 10 lần
- Kiểm tra lại xem hiện tại trên sheet đang có bao nhiều hình
Tóm lại: Nguyên tắc là phải xóa hình cũ trước khi chèn hình mới, nếu không sẽ có 1 ngày file nặng như "cục đá" mà không hiểu tại sao

phải xem file thực tế của bạn đó thì mình mới biết được là nên dùng đến Shape hay là Conditional Formatting.

 

[siwtom]

Bạn mở file, xem có đúng với yêu cầu đó ko.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
    If Not Intersect(Target, Range("I7:O15")) Is Nothing Then
    On Error GoTo Thoat 'khi xoa' vung`
        If Target.Value = 1 Then
            Set cl = Range(Target.Address)
            
            Sheets("data").Shapes("hinh1").Copy
            
            ActiveSheet.Paste
            Selection.Width = cl.Width
        End If
    End If
    
Thoat:
    [B][COLOR=#ff0000]Exit Sub[/COLOR][/B]
End Sub

Tôi không quan tâm code của bạn làm gì, làm đúng không. Tôi chỉ muốn hỏi cái đỏ đỏ nó làm gì vậy?

 

[ngoctruong142]

phải xem file thực tế của bạn đó thì mình mới biết được là nên dùng đến Shape hay là Conditional Formatting.

File mình dùng để vẽ tiến độ
Dùng Conditional Formatting là ok nhưng mà khi in ra không được đẹp.

Em sửa code giống anh nói nhưng hình nó vẫn như cũ được không vào giữa ô.

 

[phucbugis]

Tôi không quan tâm code của bạn làm gì, làm đúng không. Tôi chỉ muốn hỏi cái đỏ đỏ nó làm gì vậy?

đúng như a nói, đặt thêm cái đó --> thừa , cảm ơn a đã nhắc.

File mình dùng để vẽ tiến độ
Dùng Conditional Formatting là ok nhưng mà khi in ra không được đẹp.
Em sửa code giống anh nói nhưng hình nó vẫn như cũ được không vào giữa ô.

Mình kiểm tra lại thấy vẫn bình thường, bạn down file dưới về xem thử.
Link MediaFire: chen anh (2)

 

[ngoctruong142]

đúng như a nói, đặt thêm cái đó --> thừa , cảm ơn a đã nhắc.



Mình kiểm tra lại thấy vẫn bình thường, bạn down file dưới về xem thử.

Cám ơn anh nhiều. Đúng như anh nói khi xóa phải xóa từng shaps hơi mệt nhưng cũng có cách giải quyết.