Bom dia Pessoal!
Eu tenho uma macro que importa imagens de uma pasta especifica de acordo com a referencia dela. Por exemplo: Na coluna A2 tem uma referencia chamada Maca e na pasta X da área de trabalho ele busca a imagem Maca e posiciona na célula num tamanho especifico. Porém essa macro está em looping infinito sem parar, não consigo faze-la parar onde eu incluiria o código para isso?
Muito Obrigado
MACRO:
Sub Incluir_Imagens()
Dim Worksheet(1) As PivotTable
Resultado = MsgBox(“inicar a inclusão de imagens?”, vbYesNo, “Atualizar”)
If Resultado = vbYes Then
Application.ScreenUpdating = False
'EXCLUINDO IMAGENS
Dim DrObj
Dim Pict
Set DrObj = ActiveSheet.DrawingObjects
For Each Pict In DrObj
If Left(Pict.Name, 7) = "Picture" Then
Pict.Select
Pict.Delete
End If
Next
'incluindo Imagens
Cells.Select
Cells.EntireRow.AutoFit
Rows("1:10").EntireRow.AutoFit
Selection.Find(what:="PRODUTOCOR").Select
SEMERRO = "SIM"
Do While ActiveCell <> "-"
CHAVE = ActiveCell.Value
LIN = ActiveCell.Row
COL = ActiveCell.Column
ActiveCell.Offset(0, 0).Range("a1").Select
Selection.RowHeight = 53.25
Dim cellleft As Single
Dim celltop As Single
Dim cellwidth As Single
Dim cellheight As Single
cellleft = Selection.Left
celltop = Selection.Top
On Error GoTo COMERRO
ActiveSheet.Shapes.AddPicture("C:\Users\vfreitas\Desktop\SS 2021\" + CHAVE + ".jpg", False, True, cellleft, celltop, -1, -1).Select
REINICIAR:
If SEMERRO = "SIM" Then
If Selection.ShapeRange.Width >= 79 Then
Selection.ShapeRange.Width = 79
ElseIf Selection.ShapeRange.Height >= 45 Then
End If
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.IncrementTop 1.95
End If
Cells(LIN, COL).Select
ActiveCell.Offset(1, 0).Range("A1").Select
SEMERRO = "SIM"
Loop
Rows("10:10").EntireRow.AutoFit
Range("A1").Select
ActiveCell.SpecialCells(xlCellTypeAllFormatConditions).Select
With Selection.ColumnWidth = 6.5
End With
With ActiveSheet.PivotTables(1).TableRange2
.Cells(.Cells.Count).Select
ActiveCell.Offset(-1, -1).Select
End With
Range(Selection, Cells(1)).Select
ActiveSheet.PageSetup.PrintArea = Selection.Address
ActiveSheet.PivotTables(1).PivotSelect "PRODUTOCOR.[ALL;'Blank']", _
xlDataAndLabel, True
Selection.Borders(xlInsideVertical).LineStyle = xlNone
TABDIN.TableRange1.Select
With Selection
.VerticalAlignment = xlCenter
End With
TABDIN.DataBodyRange.Select
With Selection
.HorizontalAlignment = xlCenter
End With
TABDIN.ColumnRange.Select
With Selection
.HorizontalAlignment = xlCenter
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
TABDIN.TableRange1.Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
Range("a1:a3").Select
Selection.EntireRow.AutoFit
Range("a1").Select
'Incluir Bordas
TABDIN.DataBodyRange.Select
With Selection
.ColumnWidth = 5.85
.Borders(xlLeft).LineStyle = xlContinuous
.Borders(xlLeft).Weight = xlThin
.Borders(xlRight).LineStyle = xlContinuous
.Borders(xlRight).Weight = xlThin
End With
'FORMATAÇÃO CONDICIONAL PARA QUANTIDADES ZERADAS (PRETO)
Selection.NumberFormat = "#,##0"
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLessEqual, _
Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
End With
MsgBox ("Atualização efetuada com sucesso!!!")
Exit Sub
COMERRO:
SEMERRO = "NÃO"
ActiveCell.RowHeight = 20
ActiveCell.EntireRow.ClearFormats
Resume Next
GoTo REINICIAR
Else
MsgBox "Atualização cancelada", vbOKOnly, "Incluir Imagens"
End If
Exit Sub
End Sub