[go: up one dir, main page]
Scribd
Upload
12 views2 pages

Single Folder Not Merge

The provided VBA script inserts images into an Excel worksheet based on descriptions in a specified column. It checks for the existence of an image folder and the required sheet, then loops through each description to find and embed corresponding images from the folder. If an image is found, it is inserted into the designated 'Picture' column, adjusting its size to fit the cell dimensions.

Uploaded by

xecat15162
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
12 views2 pages

Single Folder Not Merge

The provided VBA script inserts images into an Excel worksheet based on descriptions in a specified column. It checks for the existence of an image folder and the required sheet, then loops through each description to find and embed corresponding images from the folder. If an image is found, it is inserted into the designated 'Picture' column, adjusting its size to fit the cell dimensions.

Uploaded by

xecat15162
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 2

Sub InsertPictures()

Dim parentFolder As String


Dim imgFolder As String
Dim fileName As String
Dim imgPath As String
Dim desc As String
Dim ws As Worksheet
Dim lastRow As Long
Dim img As Shape
Dim cell As Range
Dim fso As Object
Dim pictureColumn As Long

' Set the parent folder path where your images are located
parentFolder = "D:\Office\Pictures Footwears AlNasser\" ' Update this path
imgFolder = parentFolder & "4DC_PIC\" ' The folder where the images are

' Check if the image folder exists


If Len(Dir(imgFolder, vbDirectory)) = 0 Then
MsgBox "Image folder does not exist: " & imgFolder, vbExclamation
Exit Sub
End If

' Set the active sheet


On Error Resume Next ' Temporarily ignore errors to handle invalid sheet name
Set ws = ThisWorkbook.Sheets("Sheet") ' Change to your sheet name if needed
On Error GoTo 0 ' Turn off the error ignoring

' Check if the sheet exists


If ws Is Nothing Then
MsgBox """FM"" sheet not found.", vbExclamation
Exit Sub
End If

' Find the column number for the "Picture" column by searching for the header
pictureColumn = 0
For Each cell In ws.Rows(1).Cells ' Search in the first row
If cell.Value = "Picture" Then
pictureColumn = cell.Column
Exit For
End If
Next cell

' If the "Picture" column was found


If pictureColumn = 0 Then
MsgBox """Picture"" column not found.", vbExclamation
Exit Sub
End If

' Get the last row of data in column A (Desc1)


lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Create a FileSystemObject to work with files and folders


Set fso = CreateObject("Scripting.FileSystemObject")

' Loop through each row in Desc1 column


For Each cell In ws.Range("A2:A" & lastRow) ' Assuming data starts from row 2
desc = cell.Value
' Initialize the imgPath variable to an empty string for each iteration
imgPath = ""

' Search for image in the 4DC_PIC folder


If fso.FileExists(imgFolder & desc & ".jpg") Then
imgPath = imgFolder & desc & ".jpg" ' Change to .png or .jpeg if needed
End If

' If a matching image is found, insert and embed the image into the
"Picture" column
If imgPath <> "" Then
' Insert the image as an embedded object using Shapes.AddPicture
Set img = ws.Shapes.AddPicture( _
Filename:=imgPath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoCTrue, _
Left:=cell.Offset(0, pictureColumn - 1).Left, _
Top:=cell.Offset(0, pictureColumn - 1).Top, _
Width:=-1, Height:=-1)

' Adjust image size if necessary


img.LockAspectRatio = msoFalse ' Allow resizing freely
img.Width = cell.Offset(0, pictureColumn - 1).Width
img.Height = cell.RowHeight ' Match the height of the row
End If
Next cell
End Sub

You might also like