I need to insert photos automatically in a spreadsheet in Excel but my VBA code does not work the way I want

Asked

Viewed 48 times

0

Well, I looked for a solution to my problem, (for many photos at once and organized in the spreadsheet) on Youtube, forums and etc., but the nearest solution was this one, which originally filled by column, I tried to edit the code so that it could run the way I need, but it simply stacks everything in the right corner of the spreadsheet.

 Private Sub Inseri_Click()
 Dim strFolder As String
 Dim strFileName As String
 Dim objPic As Picture
 Dim rngCell As Range
 
 Dim i As Integer
 
 
  strFolder = ThisWorkbook.Path & "\" 'diz o caminho das imagens
   If Right(strFolder, 1) <> "\" Then 'verificando se esta vazio
   strFolder = strFolder & "\"
   End If
   
   Set rngCell = Range("F2")
   
   strFileName = Dir(strFolder & "*.jpg", vbNormal)
    Do While Len(strFileName) > 0
    Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
With objPic
.Left = rngCell.Left
.Top = rngCell.Top
.Height = rngCell.Height
.Placement = xlMoveAndSize
End With

If (i < 5) Then
Dim e As Integer
e = e + 1
Set rngCell = rngCell.Offset(0, e)
i = i + 1
Else
Set rngCell = rngCell.Offset(1, 0)
i = 0
End If
strFileName = Dir




 Loop
End Sub

1 answer

0

The problem is this:

.Left = rngCell.Left
.Top = rngCell.Top

Every time you pass by you put the value Set rngCell = Range("F2"). You need to place a variable and increment that value with a loop.

Example:

 For i = 1 To 6 Step 1
      ActiveSheet.Pictures.Insert(caminho).Select
            With Selection
                .Left = Cells(i, 1).Left
                .Top = Cells(i, 1).Top
                .ShapeRange.LockAspectRatio = msoFalse
                If .ShapeRange.Height > Cells(i, 1).RowHeight Then
                    .ShapeRange.Height = Cells(i, 1).RowHeight
                End If
                If .ShapeRange.Width > range("A2").Width Then
                    .ShapeRange.Width = range("A2").Width
                End If
                .ShapeRange.Rotation = 0#
                
                .Left = (range("A2", "D2").Width - .ShapeRange.Width) / 2
                .Top = Cells(i, 1).Top + (Cells(i, 1).RowHeight - .ShapeRange.Height) / 2
            End With
   next

Browser other questions tagged

You are not signed in. Login or sign up in order to post.