Reputation: 31
We have Pictures (Jpeg,Jpg,PNG) in a folder, I need to copy these pictures to excel worksheet like A2, B2, C2, D2 cells.
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.
I have used online tutorial code and changed a bit to match my requirement.
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 & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
'Sheets("Object").Range("A" & counter).Value = fls.Name
'Sheets("Object").Range("B" & counter).ColumnWidth = 25
'Sheets("Object").Range("B" & counter).RowHeight = 100
Sheets("SingleProfile").Range("A" & 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" & counter).Left
.Top = ActiveSheet.Range("A" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
Need help for Optimizing below code
As per the inputs from users i was able to get the solution which i desired.
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
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 & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 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
Upvotes: 0
Views: 4952
Reputation: 29421
For shifting through row 1 columns
.Left = ActiveSheet.Cells(counter, 1).Left
.Top = ActiveSheet.Cells(counter,1).Top
Upvotes: 1
Reputation: 3777
Instead of ActiveSheet.Range("C2")
use ActiveSheet.Cells(2,3)
and so on.
By the way, it would be safer to pass the sheet as another function parameter instead of activating it. That way you don't need to remember to activate it every time you call the function. I'd also recommend using Option Explicit
at the start of your module, especially if you're new to VBA.
Upvotes: 1