Я создал макрос Excel для своей компании, который массово вставляет изображения в папку с изображениями по значению их ячейки.
cell.Value
содержит номер SKU, поэтому я добавляю оставшуюся часть пути к файлу вa for each loop
и затем используйте ActiveSheet.Pictures.Insert(Filename).Select
.
Все отлично работает, но когда файлы не найдены в папке с изображениями, путь к файлу остается в ячейке.Я хотел бы изменить все ячейки, в которых не найдено изображение с надписью «Нет изображения», а не путь к файлу.
Есть ли способ проверить, если ActiveSheet.Pictures.Insert(Filename).Select
не удалось найти изображение, тогда я мог бы переписатьcell.Value, если это не удалось?
Я пытался добавить еще один параметр Для каждого цикла, чтобы увидеть, содержит ли cell.Value содержимое.Это связано с тем, что часть вставки изображения запускает ячейку. Очистите содержимое после того, как это будет сделано, поэтому все ячейки с вставленными изображениями не имеют своих номеров SKU за изображением.У меня возникли проблемы с этим процессом, и я хотел бы избежать повторного выбора дважды.
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub PictureImport()
Set rng = ActiveSheet.Range("A2:A3000")
For Each cell In Selection '<-- *For Each cell In rng* For Hard Coded selection
If cell.Value <> "" Then cell.Value = "\\Pictures\" & cell.Value & ".jpg" '<---NEEDS TO SKIP HEADER
Next
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A2:A3000") ' <---- CHANGE TO START AT A2 TO SKIP HEADER
For Each cell In Selection
Filename = cell
If InStr(UCase(Filename), "JPG") > 0 Then '<--- ONLY USES JPG'S
ActiveSheet.Pictures.Insert(Filename).Select
Set theShape = Selection.ShapeRange.Item(1)
If theShape Is Nothing Then GoTo isnill
xCol = cell.Column
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
cell.ClearContents
isnill:
Set theShape = Nothing
Range("A2").Select
End If
Next
Debug.Print "Done " & Now
Application.ScreenUpdating = True
End Sub
Фактические результаты в виде подставок: изображения из папки с изображениями будут вставлены в размер ячейки., но оставит ячейки, которые не смогли найти изображение с путем к файлу, все еще в значении ячейки.