title: Copy images from Folder and paste it to Excel through VBA
body: <p>We have Pictures (Jpeg,Jpg,PNG) in a folder, I need to copy these pictures to excel worksheet like A2, B2, C2, D2 cells.</p>
  
  <p>Using below code i am able to copy as A2,A3,A4 and so on but how to change colunm in below code instead of Row. I could make row constant by keeping counter constant.</p>
  
  <p>I have used online tutorial code and changed a bit to match my requirement.</p>
  
  <pre><code>Sub AddOlEObject()
  
      Dim mainWorkBook As Workbook
  
      Set mainWorkBook = ActiveWorkbook
      Sheets("SingleProfile").Activate
      Folderpath = "C:\Users\sandeep.hc\Pics"
      Set fso = CreateObject("Scripting.FileSystemObject")
      NoOfFiles = fso.GetFolder(Folderpath).Files.Count
      Set listfiles = fso.GetFolder(Folderpath).Files
      For Each fls In listfiles
         strCompFilePath = Folderpath &amp; "\" &amp; Trim(fls.Name)
          If strCompFilePath &lt;&gt; "" Then
              If (InStr(1, strCompFilePath, "jpg", vbTextCompare) &gt; 1 _
              Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) &gt; 1 _
              Or InStr(1, strCompFilePath, "png", vbTextCompare) &gt; 1) Then
                   counter = counter + 1
                    'Sheets("Object").Range("A" &amp; counter).Value = fls.Name
                    'Sheets("Object").Range("B" &amp; counter).ColumnWidth = 25
                  'Sheets("Object").Range("B" &amp; counter).RowHeight = 100
                  Sheets("SingleProfile").Range("A" &amp; counter).Activate
                  Call insert(strCompFilePath, counter)
                  Sheets("SingleProfile").Activate
              End If
          End If
      Next
  mainWorkBook.Save
  End Sub
  
  Function insert(PicPath, counter)
  'MsgBox PicPath
      With ActiveSheet.Pictures.insert(PicPath)
          With .ShapeRange
              .LockAspectRatio = msoFalse
              '.Width = 50
              '.Height = 70
          End With
          .Left = ActiveSheet.Range("A" &amp; counter).Left
          .Top = ActiveSheet.Range("A" &amp; counter).Top
          .Placement = 1
          .PrintObject = True
      End With
  End Function
  </code></pre>
  
  <p><strong>Need help for Optimizing below code</strong></p>
  
  <p>As per the inputs from users i was able to get the solution which i desired. </p>
  
  <p>I want to optimize the code now, as i am very novice in coding can some one help to optimize or help good coding techniques to improve below </p>
  
  <pre><code>Sub AddOlEObject()
  
      Dim mainWorkBook As Workbook
  
      Set mainWorkBook = ActiveWorkbook
      Sheets("SingleProfile").Activate
      Folderpath = "C:\Users\sandeep.hc\Pics"
      Set fso = CreateObject("Scripting.FileSystemObject")
      NoOfFiles = fso.GetFolder(Folderpath).Files.Count
      Set listfiles = fso.GetFolder(Folderpath).Files
      For Each fls In listfiles
         strCompFilePath = Folderpath &amp; "\" &amp; Trim(fls.Name)
          If strCompFilePath &lt;&gt; "" Then
              If (InStr(1, strCompFilePath, "jpg", vbTextCompare) &gt; 1 _
              Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) &gt; 1 _
              Or InStr(1, strCompFilePath, "png", vbTextCompare) &gt; 1) Then
                   counter = 29
                   counter1 = counter1 + 1
  
                  Call insert(strCompFilePath, counter, counter1)
                  'Sheets("SingleProfile").Activate
                  counter1 = counter1 + 17
              End If
          End If
      Next
  mainWorkBook.Save
  End Sub
  
  Function insert(PicPath, counter, counter1)
  'MsgBox PicPath
      With ActiveSheet.Pictures.insert(PicPath)
          With .ShapeRange
              .LockAspectRatio = msoFalse
              .Width = 875
              .Height = 300
          End With
          .Left = ActiveSheet.Cells(counter, counter1).Left
          .Top = ActiveSheet.Cells(counter, counter1).Top
          .Placement = 1
          .PrintObject = True
      End With
  End Function
  </code></pre>