Способ сказать, если ActiveSheet.Pictures.Insert (Filename) .Select Fails? - PullRequest
0 голосов
/ 25 июня 2019

Я создал макрос 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

Фактические результаты в виде подставок: изображения из папки с изображениями будут вставлены в размер ячейки., но оставит ячейки, которые не смогли найти изображение с путем к файлу, все еще в значении ячейки.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...