Đánh dấu ô không có hình khi chèn ảnh tự động

Chia sẻ bởi:hands

★★★★★

‹ Viết lại chuỗi căn cứ vào dữ... Em nhờ các Anh Chị trên group... ›

Quảng cáo

Hiện tại mình đã dùng cách thức này để chèn ảnh hàng loạt. Khi bấm chèn hình sẽ hiện chọn ô chứa Link và chọn ô ra hình ảnh. Mỗi lần mình xuất cả 1000 hình. Không biết mình nên thêm gì để đối với những ô không có hình sẽ đánh dấu X, giống hình bên dưới
4084
Mình xin gửi Code và File luôn ạ

Option Explicit

Sub ChenAnh()
Dim rS As Range
Dim rD As Range
On Error Resume Next

Set rS = Application.InputBox("Vung chua link anh", Type:=8)
If Err.Number <> 0 Then Exit Sub
Set rD = Application.InputBox("Vung chua anh", Type:=8)
If Err.Number <> 0 Then Exit Sub
InsertPicture rS, rD, True

End Sub

Private Function AutoPicture(rPath As Range)
Dim ca  As Range
Application.Volatile
Set ca = Application.Caller

AutoPicture = InsertPicture(rPath, Application.Caller, False)
End Function

Private Sub ClearPicture(rrg As Range, isSubCall As Boolean)
Dim Ws As Worksheet
Dim pPics As Pictures
Dim pPic As Picture

On Error Resume Next
Set Ws = rrg.Worksheet

If isSubCall = True Then
    'xoa anh nam tren cell
    Set pPics = Ws.Pictures
    For Each pPic In pPics
        If Not (Application.Intersect(rrg, pPic.TopLeftCell) Is Nothing) Then
            If Not (Application.Intersect(rrg, pPic.BottomRightCell) Is Nothing) Then
                pPic.Delete

End If
        End If
    Next
Else
    Dim rIndex As Range
    For Each rIndex In rrg
        Set pPic = Ws.Shapes(rIndex)
        pPic.Delete
    Next

End If

End Sub

Private Function InsertPicture(rS As Range, rD As Range, Optional isSubCall As Boolean = True)

Dim lRows As Long
Dim lCols As Long
Dim lRow As Long
Dim lCol As Long
Dim rrg As Range
Dim Pic As Shape
Dim Ws As Worksheet
Set Ws = rD.Worksheet

lRows = rS.Rows.Count
lCols = rD.Columns.Count

If rS.Rows.Count <> rD.Rows.Count Or rS.Columns.Count <> rD.Columns.Count Then InsertPicture = CVErr(xlErrNA): Exit Function

On Error Resume Next
If isSubCall = True Then
    If MsgBox("Xoa anh cu", vbYesNo) = vbYes Then
        ClearPicture rD, True 'xoa cac anh cu
    End If

Else
    ClearPicture rD, False 'xoa anh voi tu cach ham
End If

Dim vKQ() As Variant
ReDim vKQ(1 To lRows, 1 To lCols) As Variant

For lRow = 1 To lRows
    For lCol = 1 To lCols
        Set rrg = rD(lRow, lCol)
        Err.Clear

Set Pic = Ws.Shapes.AddPicture("chienhuy.com/wp-content/uploads/2021/09/" & rS(lRow, lCol), msoFalse, msoTrue, 1, 1, -1, -1)

If Err.Number <> 0 Then
            vKQ(lRow, lCol) = CVErr(xlErrNA)
        Else
            vKQ(lRow, lCol) = Pic.Name
            Pic.Placement = xlMoveAndSize
            ReSizeShape Pic, rrg
        End If

Next
Next lRow

InsertPicture = vKQ

End Function

Private Sub ReSizeShape(a As Shape, rrg As Range)

Dim shr As Single
Dim swr As Single
Dim sha As Single
Dim swa As Single
Dim sTyLe As Single

a.LockAspectRatio = msoFalse
a.ScaleHeight 1, msoTrue, msoScaleFromMiddle
a.ScaleWidth 1, msoTrue, msoScaleFromMiddle

'shr = rrg.Height
'swr = rrg.Width

shr = rrg.MergeArea.Height
swr = rrg.MergeArea.Width

sha = a.Height
swa = a.Width
sTyLe = 10
If (shr / swr) >= (sha / swa) Then
    'a.Width = rrg.Width * (100 - sTyLe) / 100
    a.Width = swr * (100 - sTyLe) / 100

a.Height = (a.Width * sha) / swa

Else
    'a.Height = rrg.Height * (100 - sTyLe) / 100
    a.Height = shr * (100 - sTyLe) / 100
    a.Width = (a.Height * swa) / sha

End If
'a.Left = rrg.Left + (rrg.Width - a.Width) / 2
'a.Top = rrg.Top + (rrg.Height - a.Height) / 2

a.Left = rrg.Left + (swr - a.Width) / 2
a.Top = rrg.Top + (shr - a.Height) / 2

a.LockAspectRatio = msoTrue
End Sub

Thì bạn thêm dòng này vào cái Private Function InsertPicture thử:

If Pic.Name <> rS Then rD = "X"

Mình đã thử cách của bạn nhưng ô nào cũng đánh dấu "X" hết, kể cả có hình. Bạn có thể hướng dẫn chèn vào khu vực nào được không ạ, mình không rành lắm.

Chào các bạn trong "giaiphapexcel"

Hiện tại mình có 1 đoạn code chèn hình ảnh từ link. Sau khi chèn lần 1 là nó sẽ chèn hết tất cả các hình ảnh từ link đó.
Khi mình thêm link mới vào thì nó sẽ update từ đầu. nên chạy rất chậm.
Mình muốn khi có link mới thì nó sẽ hiểu là chỉ chèn ảnh từ link mới đó thôi. để khắc phục tình trạng load lại từ đâu.
Mong mọi người giúp đỡ.
Mình có gửi file đính kèm ạ.
Cảm ơn.

Đoạn code đây ạ.

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A3:A1000")
For Each cell In rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
.Top = xRg.Top + (xRg.Height – .Height) / 2
.Left = xRg.Left + (xRg.Width – .Width) / 2
End With
lab:
Set Pshp = Nothing
Next
Application.ScreenUpdating = True
End Sub

Tôi chỉ đặt vùng và xác định điều kiện cho code thôi, chứ nó chèn hình sai đúng thế nào thì không biết:

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A3:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
For Each cell In Rng
    If cell.Offset(0, 2) = "" Then
        filenam = cell
        ActiveSheet.Pictures.Insert(filenam).Select
        Set Pshp = Selection.ShapeRange.Item(1)
        If Pshp Is Nothing Then GoTo lab
        xCol = cell.Column + 1
        Set xRg = Cells(cell.Row, xCol)
        With Pshp
            .LockAspectRatio = msoFalse
            If .Width > xRg.Width Then .Width = xRg.Width * 2 / 3
            If .Height > xRg.Height Then .Height = xRg.Height * 2 / 3
            .Top = xRg.Top + (xRg.Height - .Height) / 2
            .Left = xRg.Left + (xRg.Width - .Width) / 2
        End With
        xRg.Offset(0, 1) = "OK"
lab:
        Set Pshp = Nothing
    End If
Next
Application.ScreenUpdating = True
End Sub

www.giaiphapexcel.com/diendan/threads/%C4%90%C3%A1nh-d%E1%BA%A5u-%C3%B4-kh%C3%B4ng-c%C3%B3-h%C3%ACnh-khi-ch%C3%A8n-%E1%BA%A3nh-t%E1%BB%B1-%C4%91%E1%BB%99ng.157640/