Que hacer ante un problema personal. Lugar para pedir consejo o asesoramiento sobre temas que a diario nos pueden suceder.
¿No sabes donde encontrar ayuda?, pues pregunta aquí, tal vez te podamos aconsejar.
Hola buen día
Tengo un problema que no he encontrado solución
Debo realizar un trabajo en el que debo insertar más de 500 imágenes y que estas queden ajustadas a las celdas
La imagen adjunta es solo un ejemplo, ya que no cuento con el documento original en mi pc
He estado leyendo varios sitios en inglés que te dan los códigos para insertarlos en visual basic, ya logré entender como se introducen los códigos. Pero no tengo idea de que modificar para que relacione el nombre de la celda, con el nombre de la imagen, y esta última la coloque en la celda deseada.
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\Sumit Jain\Pictures"
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("Object").Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Object").Activate
End If
End If
Next
mainWorkBook.Save
End Sub
Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 50
.Height = 70
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
En este punto cualquier ayuda o sugerencia que me puedan brindar me viene bien.
De antemano muchas gracias.
Última edición por Mondeo14 el Dom Dic 18, 2016 3:09 am, editado 1 vez en total.
Hola. Hace mucho tiempo que no programo en VB, pero intentaré explicarte un poco. Si has copiado el código literalmente lo primero que tienes que hacer es nombrar una hoja como "Object" o cambiar en las líneas donde se invoca Sheets el nombre por el que tengas en tu hoja. Para asociar los archivos tienes que cambiar la dirección en la línea Folderpath. Ahí tienes que poner la dirección completa donde tienes la carpeta con las imágenes. Según está ese código, te va a poner las imágenes en la columna B y los nombres de los archivos en la columna A. Saludos
Gracias por la respuesta.
Realicé los cambios que me aconsejaste
Pero cuando trato de correr el código me marca el siguiente error y me señala la primer linea en amarillo
¿Qué estoy haciendo mal?
Private Sub CommandButton1_Click()
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
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("Object").Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Object").Activate
End If
End If
Next
mainWorkBook.Save
End Sub
Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 50
.Height = 70
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
Última edición por Mondeo14 el Dom Dic 18, 2016 3:09 am, editado 1 vez en total.
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
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("Object").Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Object").Activate
End If
End If
Next
mainWorkBook.Save
End Sub
Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 50
.Height = 70
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
Ahora el problema es que cuando corro el código no hace lo que esperaba
Lo que hace es que me pega la imagen desde la celda "B1" y pega el nombre de la imagen en la columna "A1"
y así sucesivamente.
Los valores de la columna "A" están todos definidos y no cambian.
Lo que necesito es que inserte la imagen en la celda "B2, B3..." si coincide con el valor de la celda "A2, A3..."
Alguna idea?
Última edición por Mondeo14 el Dom Dic 18, 2016 3:09 am, editado 1 vez en total.
No sé si te he entendido bien.¿Quieres que coincida el nombre con la imagen? Eso ya lo hace ahora.A mi entender lo mejor sería que pusiera las imágenes, por ejemplo, en unas 5 columnas y las filas hasta que terminen. Si no quieres que ponga el nombre en la columna A, pon una " ' " antes de la línea Sheets("Object").Range("A" & counter).Value = fls.Name.
Gracias con ese cambio ya no reemplaza los nombres de la primera columna
Lamentablemente el formato que debo usar ya esta prediseñado y hay poco que puedo cambiar en cuanto al layout
Esta es una representación aproximada.
Viene a ser como un catalogo muy grande con al rededor de 400 números diferentes en la columna "A" y cada número tiene dos imágenes las cuales deben ir en su respectiva celda
Por lo cual el código tiene que poner la imagen "IMG001" en la columna "C4" solo si coincide que el valor de la celda "A4" es "IMG001"
Y así sucesivamente.
Esa es la razón por lo cual no puedo hacerlo manualmente. Ya que debería estar insertando una por una y ajustarlas manualmente a la celda.
Ya comprobé que el código funciona perfecto para insertar múltiples imágenes y ajustarlas a la celda. Solo necesito que las inserte en el orden que expliqué anteriormente.
Hay esperanza?
Muchas gracias por tu ayuda
Última edición por Mondeo14 el Dom Dic 18, 2016 3:09 am, editado 1 vez en total.
Hola. Se puede hacer fácilmente lo que propones en la segunda imagen, pero antes me tienes que explicar por qué has nombrado a la función precisamente "AddOLEobject", desde dónde llamas a esa función para que se ejecute o si lo hace por ejemplo al abrirse el libro, activarse la hoja, etc...
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A"
picturePasteColumn = "B"
pictureRow = 2 'starts from this row
'error handler
On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
'Start If block with .JPG
If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End If block with .JPG
'Start ElseIf block with .PNG
ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .PNG
'Start ElseIf block with .BMP
ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .BMP
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub
End Sub
Última edición por Mondeo14 el Dom Dic 18, 2016 3:09 am, editado 1 vez en total.
Hola. Haz esto: En el primer código inserta la línea "counter=3" antes de la línea " For Each fls In listfiles...". Cambia el valor de Range en todas las líneas donde aparezca por la letra de la columna que prefieras (creo que en tu caso la C). Ahora copia el código entero y ponlo en un sitio diferente (módulo, procedimiento, etc..). Cambia la dirección de la carpeta de las imágenes que quieras poner y cambia el valor Range con la letra H. Si lo ejecutas directamente desde VB funcionará, aunque sería mejor llamar la función con un procedimiento, pero bueno creo que te servirá.