Multiple images into excel using VBA

Have a look at the documentation for the AddPicture method:

https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel

expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

Rather than adding the picture at the active cell, it's location is controlled by the Left and Top arguments. You can use the Left and Top properties of the target cell as the arguments of the AddPicture method:

ws.Shapes.AddPicture strCompFilePath, True, True, ws.Range("D" & counter).Left, ws.Range("D" & counter).Top,70,70

Here's a version that uses copy/paste instead of export/import - it does include the line to change the row height if you want to crib just that.. :P

Sub ExtractImagesFromPres()
    Dim oSldSource As Slide
    Dim oShpSource As Shape
    Dim ObjExcel As Object
    Dim wb As Object
    Dim ws As Object
    Set ObjExcel = CreateObject("Excel.Application")
    Dim lOffset AS Long

    Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
    Set ws = wb.Sheets(1)

    'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
    lOffset = 5
    For Each oSldSource In ActivePresentation.Slides
        For Each oShpSource In oSldSource.Shapes
            If oShpSource.Type = msoPicture Then
                oShpSource.Copy
                ws.Paste
                With ws.Shapes(ws.Shapes.Count)
                    .Top = lOffset 
                    .Left = 5
                    .Placement = 3 'xlFreeFloating
                    'This line sets the row height!
                    .TopLeftCell.EntireRow.RowHeight = 10 + .Height
                    lOffset = lOffset + .Height + 10
                End With
            End If
        Next oShpSource
    Next oSldSource

    'Optional Tidy-Up code
    'Set ws = Nothing
    'wb.Save
    'Set wb = Nothing
    'ObjExcel.Quit
    'Set ObjExcel = Nothing
End Sub

I'm 100% certain you can export the images from PPT directly to XLS, but I'm not really sure how to do that. However, since you are able to export those images from PPT into a folder, and you just need help importing the images from there, I thin the code below will do just what you want.

Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range

Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1

For Each r In rng
    fName = Dir(fPath)
    Do While fName <> ""
        If fName = r.Value Then
            With ActiveSheet.Pictures.Insert(fPath & fName)
                .ShapeRange.LockAspectRatio = msoTrue
                Set px = .ShapeRange
                If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
                    With Cells(i, 2)
                        px.Top = .Top
                        px.Left = .Left
                        .RowHeight = px.Height
                    End With
            End With
        End If
        fName = Dir
    Loop
    i = i + 1
Next r
Application.ScreenUpdating = True
End Sub

' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.


Sub Insert()

    Dim strFolder As String
    Dim strFileName As String
    Dim objPic As Picture
    Dim rngCell As Range

    strFolder = "C:\Users\Public\Pictures\Sample Pictures\" 'change the path accordingly
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If

    Set rngCell = Range("E1") 'starting cell

    strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files

    Do While Len(strFileName) > 0
        Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
        With objPic
            .Left = rngCell.Left
            .Top = rngCell.Top
            .Height = rngCell.RowHeight
            .Placement = xlMoveAndSize
        End With
        Set rngCell = rngCell.Offset(1, 0)
        strFileName = Dir
    Loop

End Sub