Erreur for without next

Bonjour,

J'ai fait ma macro, mais j'ai toujours l'erreur for without next. Voyez-vous où est mon erreur?

Sub Addpictures()

Application.Calculation = xlManual

Application.ScreenUpdating = False

Dim i As Integer

Dim j As Integer

Dim Filename As String

Dim Path As String

Dim ObjFSO As Object

Dim ObjFolder As Object

Dim ObjectFile As Object

Worksheets("Corporate").Activate

ActiveSheet.DrawingObjects.Delete

On Error Resume Next

Set ObjFSO = CreateObject("Scripting.FileSystemObject")

Set ObjFolder = ObjFSO.GetFolder("\\saneth03\StylesImage\")

For j = 7 To 50

For i = 5 To 50

If Worksheets("Corporate").Cells(i, j).Value = "" Then

'do nothing

Filename = Worksheets("Corporate").Cells(i, j).Value

Else

For Each ObjectFile In ObjFolder.Files

If ObjectFile.Name Like (Filename & "*") Then

With ActiveSheet.Pictures.Insert(ObjectFile.Path)

With .ShapeRange.LockAspectRatio = msoFalse

.Height = 80

.Width = 50

End With

.Left = ActiveSheet.Cells(i, j).Left

.Top -ActiveSheet.Cells(i, j).Top

.Placement = 1 'locks the picture to a cell

End With

End If

i = i + 1

j = j + 25

Next ObjectFile

End If

End Sub

Bonjour,

Sans garantie de résultat.

Cdlt.

Sub AddPictures()
Dim ws As Worksheet
Dim ObjFSO As Object, ObjFolder As Object, ObjectFile As Object
Dim Filename As String
Dim I As Long, J As Long

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Set ws = ActiveWorkbook.Worksheets("Corporate")
    ws.DrawingObjects.Delete

    Set ObjFSO = CreateObject("Scripting.FileSystemObject")
    Set ObjFolder = ObjFSO.GetFolder("\\saneth03\StylesImage\")

    For J = 7 To 50 Step 25
        For I = 5 To 50
            If ws.Cells(I, J).Value <> "" Then
                For Each ObjectFile In ObjFolder.Files
                    If ObjectFile.Name Like (Filename & "*") Then
                        With ws.Pictures.Insert(ObjectFile.Path)
                            With .ShapeRange.LockAspectRatio = msoFalse
                                .Height = 80
                                .Width = 50
                            End With
                            .Left = ws.Cells(I, J).Left
                            .Top = ws.Cells(I, J).Top
                            .Placement = 1    'locks the picture to a cell
                        End With
                    End If
                Next ObjectFile
            End If
        Next I
    Next J

End Sub

Bonjour,

il manquait 2 next ( i et j)

Sub Addpictures()

Application.Calculation = xlManual
Application.ScreenUpdating = False

Dim i As Integer
Dim j As Integer
Dim Filename As String
Dim Path As String
Dim ObjFSO As Object
Dim ObjFolder As Object
Dim ObjectFile As Object

Worksheets("Corporate").Activate
ActiveSheet.DrawingObjects.Delete

On Error Resume Next

Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set ObjFolder = ObjFSO.GetFolder("\\saneth03\StylesImage\")

For j = 7 To 50
 For i = 5 To 50

    If Worksheets("Corporate").Cells(i, j).Value = "" Then
    'do nothing

    Filename = Worksheets("Corporate").Cells(i, j).Value
    Else

      For Each ObjectFile In ObjFolder.Files
        If ObjectFile.Name Like (Filename & "*") Then
            With ActiveSheet.Pictures.Insert(ObjectFile.Path)
               With .ShapeRange.LockAspectRatio = msoFalse
                .Height = 80
                .Width = 50
               End With
              .Left = ActiveSheet.Cells(i, j).Left
              .Top -ActiveSheet.Cells(i, j).Top
              .Placement = 1 'locks the picture to a cell
            End With
        End If

        i = i + 1
        j = j + 25
       Next ObjectFile
    End If
  Next i
Next j

End Sub