Insertar archivo en el orden de selección con EXCEL VBA
Tengo el siguiente inconveniente, estoy realizando una macro que me inserte imágenes en casillas, recorriendo un ciclo, y todo funciona bien, pero cuando selecciono las imágenes con "getopenfilename" estas se insertan ordenadas por nombre, ¿hay alguna forma de insertarlas por orden de Selección?
Sub insertar()
On Error Resume Next
Dim PicFormat As String
Dim Rng As Range
Piclist = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
If IsArray(Piclist) Then
FilaInsertar = Application.ActiveCell.Row
ColumnaInsertar = Application.ActiveCell.Column
Inicio = LBound(Piclist)
Final = UBound(Piclist)
For lLoop = Inicio To Final
Set Rng = Cells(FilaInsertar, ColumnaInsertar)
Set sShape = ActiveSheet.Shapes.AddPicture(Piclist(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
ColumnaInsertar = ColumnaInsertar + 1
Next
End If
End Sub
2 respuestas
Es una idea, algo laboriosa, pero funciona.
Tienes que crear un userform con un listbox, un botón para cargar los archivos y otro botón para insertar las imágenes seleccionadas a la hoja:
Podrías cargar todos los archivos de la carpeta en una hoja y esos mismos archivos en un listbox. El listbox deberá tener las propiedades Multiselect = 1 y listStyle = 1
Entonces, podrás ir seleccionando los archivos en el list, y en el evento change almacenar cada selección en la celda según el orden seleccionado.
Después presiona el botón "Inerstar" para insertar las imágenes en las celdas.
Funciona de la siguiente manera. Crea una hoja llamada "Temp". Cambia en el código "Hoja2" por el nombre de tu hoja donde quieres insertar las imágenes.
También cambia en el código ruta = "C:\Trabajo\imagen\" por la carpeta donde tienes las imágenes.
Selecciona tu hoja, selecciona la celda donde quieres iniciar a insertar. Abre el formulario. Presiona el botón Cargar
Cuando aparezcan los nombres de los archivos, activa la casilla de cada archivo según el nombre en que quieres que se cargue. También puedes desmarcar la casilla y los otros archivos marcados conservarán su orden de selección.
Presiona el botón "Insertar" para insertar los archivos.
El código:
Dim h1, h2, ruta
'
Private Sub CommandButton1_Click()
'Por.Dante Amor
'
u = h1.Range("A" & Rows.Count).End(xlUp).Row
With h1.Sort
.SortFields.Clear
.SortFields.Add Key:=h1.Range("B1:B" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange h1.Range("A1:B" & u)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
FilaInsertar = ActiveCell.Row
ColumnaInsertar = ActiveCell.Column
For i = 1 To h1.Range("B" & Rows.Count).End(xlUp).Row
If h1.Cells(i, "B") <> "" Then
arch = h1.Cells(i, "A")
Set Rng = h2.Cells(FilaInsertar, ColumnaInsertar)
Set sShape = h2.Shapes.AddPicture(ruta & arch, msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
ColumnaInsertar = ColumnaInsertar + 1
End If
Next
MsgBox "Fin"
End Sub
'
Private Sub CommandButton2_Click()
'Por.Dante Amor
Set h1 = Sheets("Temp") 'hoja temporal
Set h2 = Sheets("Hoja2") 'hoja para poner las imágenes
'
h1.Columns("A:B").ClearContents
ruta = "C:\Trabajo\imagen\"
arch = Dir(ruta & "*.*")
i = 1
Do While arch <> ""
h1.Cells(i, "A") = arch
i = i + 1
arch = Dir()
Loop
u = h1.Range("A" & Rows.Count).End(xlUp).Row
ListBox1.RowSource = h1.Name & "!" & h1.Range("A1:A" & u).Address
End Sub
'
Private Sub ListBox1_Change()
'Por.Dante Amor
u = h1.Range("A" & Rows.Count).End(xlUp).Row
Set r = h1.Range("B1:B" & u)
If ListBox1.Selected(ListBox1.ListIndex) Then
h1.Cells(ListBox1.ListIndex + 1, "B") = WorksheetFunction.Max(r) + 1
Else
h1.Cells(ListBox1.ListIndex + 1, "B") = ""
End If
End SubAvísame si quieres mi archivo de prueba.
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
.
está interesante Dante adjuntar a mi Email por favor saludos! - Adriel Ortiz Mangia